├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── configure ├── docs ├── Websocketml.Http.html ├── Websocketml.Logger.html ├── Websocketml.html ├── css │ ├── colors.css │ └── doc_style.css ├── index.html ├── index_attributes.html ├── index_class_types.html ├── index_classes.html ├── index_exceptions.html ├── index_extensions.html ├── index_methods.html ├── index_module_types.html ├── index_modules.html ├── index_types.html ├── index_values.html ├── type_Websocketml.Http.html ├── type_Websocketml.Logger.html └── type_Websocketml.html ├── examples ├── Makefile └── echo │ ├── Makefile │ ├── echo_client.html │ └── echo_server.ml ├── src ├── Makefile ├── base64.ml ├── http.ml ├── logger.ml ├── sha1.ml ├── utils.ml ├── websocketml.ml ├── websocketml.mli └── ws.ml ├── test ├── Makefile ├── test_base64.ml └── test_sha1.ml └── websocketml.opam /.gitignore: -------------------------------------------------------------------------------- 1 | config 2 | META 3 | 4 | *.annot 5 | *.cmo 6 | *.cma 7 | *.cmi 8 | *.a 9 | *.o 10 | *.cmx 11 | *.cmxs 12 | *.cmxa 13 | 14 | # ocamlbuild working directory 15 | _build/ 16 | 17 | # ocamlbuild targets 18 | *.byte 19 | *.native 20 | 21 | # oasis generated files 22 | setup.data 23 | setup.log 24 | 25 | # Merlin configuring file for Vim and Emacs 26 | .merlin 27 | 28 | # ocamldep output 29 | .depend 30 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | CeCILL-C FREE SOFTWARE LICENSE AGREEMENT 2 | 3 | 4 | Notice 5 | 6 | This Agreement is a Free Software license agreement that is the result 7 | of discussions between its authors in order to ensure compliance with 8 | the two main principles guiding its drafting: 9 | 10 | * firstly, compliance with the principles governing the distribution 11 | of Free Software: access to source code, broad rights granted to 12 | users, 13 | * secondly, the election of a governing law, French law, with which 14 | it is conformant, both as regards the law of torts and 15 | intellectual property law, and the protection that it offers to 16 | both authors and holders of the economic rights over software. 17 | 18 | The authors of the CeCILL-C (for Ce[a] C[nrs] I[nria] L[ogiciel] L[ibre]) 19 | license are: 20 | 21 | Commissariat � l'Energie Atomique - CEA, a public scientific, technical 22 | and industrial research establishment, having its principal place of 23 | business at 25 rue Leblanc, immeuble Le Ponant D, 75015 Paris, France. 24 | 25 | Centre National de la Recherche Scientifique - CNRS, a public scientific 26 | and technological establishment, having its principal place of business 27 | at 3 rue Michel-Ange, 75794 Paris cedex 16, France. 28 | 29 | Institut National de Recherche en Informatique et en Automatique - 30 | INRIA, a public scientific and technological establishment, having its 31 | principal place of business at Domaine de Voluceau, Rocquencourt, BP 32 | 105, 78153 Le Chesnay cedex, France. 33 | 34 | 35 | Preamble 36 | 37 | The purpose of this Free Software license agreement is to grant users 38 | the right to modify and re-use the software governed by this license. 39 | 40 | The exercising of this right is conditional upon the obligation to make 41 | available to the community the modifications made to the source code of 42 | the software so as to contribute to its evolution. 43 | 44 | In consideration of access to the source code and the rights to copy, 45 | modify and redistribute granted by the license, users are provided only 46 | with a limited warranty and the software's author, the holder of the 47 | economic rights, and the successive licensors only have limited liability. 48 | 49 | In this respect, the risks associated with loading, using, modifying 50 | and/or developing or reproducing the software by the user are brought to 51 | the user's attention, given its Free Software status, which may make it 52 | complicated to use, with the result that its use is reserved for 53 | developers and experienced professionals having in-depth computer 54 | knowledge. Users are therefore encouraged to load and test the 55 | suitability of the software as regards their requirements in conditions 56 | enabling the security of their systems and/or data to be ensured and, 57 | more generally, to use and operate it in the same conditions of 58 | security. This Agreement may be freely reproduced and published, 59 | provided it is not altered, and that no provisions are either added or 60 | removed herefrom. 61 | 62 | This Agreement may apply to any or all software for which the holder of 63 | the economic rights decides to submit the use thereof to its provisions. 64 | 65 | 66 | Article 1 - DEFINITIONS 67 | 68 | For the purpose of this Agreement, when the following expressions 69 | commence with a capital letter, they shall have the following meaning: 70 | 71 | Agreement: means this license agreement, and its possible subsequent 72 | versions and annexes. 73 | 74 | Software: means the software in its Object Code and/or Source Code form 75 | and, where applicable, its documentation, "as is" when the Licensee 76 | accepts the Agreement. 77 | 78 | Initial Software: means the Software in its Source Code and possibly its 79 | Object Code form and, where applicable, its documentation, "as is" when 80 | it is first distributed under the terms and conditions of the Agreement. 81 | 82 | Modified Software: means the Software modified by at least one 83 | Integrated Contribution. 84 | 85 | Source Code: means all the Software's instructions and program lines to 86 | which access is required so as to modify the Software. 87 | 88 | Object Code: means the binary files originating from the compilation of 89 | the Source Code. 90 | 91 | Holder: means the holder(s) of the economic rights over the Initial 92 | Software. 93 | 94 | Licensee: means the Software user(s) having accepted the Agreement. 95 | 96 | Contributor: means a Licensee having made at least one Integrated 97 | Contribution. 98 | 99 | Licensor: means the Holder, or any other individual or legal entity, who 100 | distributes the Software under the Agreement. 101 | 102 | Integrated Contribution: means any or all modifications, corrections, 103 | translations, adaptations and/or new functions integrated into the 104 | Source Code by any or all Contributors. 105 | 106 | Related Module: means a set of sources files including their 107 | documentation that, without modification to the Source Code, enables 108 | supplementary functions or services in addition to those offered by the 109 | Software. 110 | 111 | Derivative Software: means any combination of the Software, modified or 112 | not, and of a Related Module. 113 | 114 | Parties: mean both the Licensee and the Licensor. 115 | 116 | These expressions may be used both in singular and plural form. 117 | 118 | 119 | Article 2 - PURPOSE 120 | 121 | The purpose of the Agreement is the grant by the Licensor to the 122 | Licensee of a non-exclusive, transferable and worldwide license for the 123 | Software as set forth in Article 5 hereinafter for the whole term of the 124 | protection granted by the rights over said Software. 125 | 126 | 127 | Article 3 - ACCEPTANCE 128 | 129 | 3.1 The Licensee shall be deemed as having accepted the terms and 130 | conditions of this Agreement upon the occurrence of the first of the 131 | following events: 132 | 133 | * (i) loading the Software by any or all means, notably, by 134 | downloading from a remote server, or by loading from a physical 135 | medium; 136 | * (ii) the first time the Licensee exercises any of the rights 137 | granted hereunder. 138 | 139 | 3.2 One copy of the Agreement, containing a notice relating to the 140 | characteristics of the Software, to the limited warranty, and to the 141 | fact that its use is restricted to experienced users has been provided 142 | to the Licensee prior to its acceptance as set forth in Article 3.1 143 | hereinabove, and the Licensee hereby acknowledges that it has read and 144 | understood it. 145 | 146 | 147 | Article 4 - EFFECTIVE DATE AND TERM 148 | 149 | 150 | 4.1 EFFECTIVE DATE 151 | 152 | The Agreement shall become effective on the date when it is accepted by 153 | the Licensee as set forth in Article 3.1. 154 | 155 | 156 | 4.2 TERM 157 | 158 | The Agreement shall remain in force for the entire legal term of 159 | protection of the economic rights over the Software. 160 | 161 | 162 | Article 5 - SCOPE OF RIGHTS GRANTED 163 | 164 | The Licensor hereby grants to the Licensee, who accepts, the following 165 | rights over the Software for any or all use, and for the term of the 166 | Agreement, on the basis of the terms and conditions set forth hereinafter. 167 | 168 | Besides, if the Licensor owns or comes to own one or more patents 169 | protecting all or part of the functions of the Software or of its 170 | components, the Licensor undertakes not to enforce the rights granted by 171 | these patents against successive Licensees using, exploiting or 172 | modifying the Software. If these patents are transferred, the Licensor 173 | undertakes to have the transferees subscribe to the obligations set 174 | forth in this paragraph. 175 | 176 | 177 | 5.1 RIGHT OF USE 178 | 179 | The Licensee is authorized to use the Software, without any limitation 180 | as to its fields of application, with it being hereinafter specified 181 | that this comprises: 182 | 183 | 1. permanent or temporary reproduction of all or part of the Software 184 | by any or all means and in any or all form. 185 | 186 | 2. loading, displaying, running, or storing the Software on any or 187 | all medium. 188 | 189 | 3. entitlement to observe, study or test its operation so as to 190 | determine the ideas and principles behind any or all constituent 191 | elements of said Software. This shall apply when the Licensee 192 | carries out any or all loading, displaying, running, transmission 193 | or storage operation as regards the Software, that it is entitled 194 | to carry out hereunder. 195 | 196 | 197 | 5.2 RIGHT OF MODIFICATION 198 | 199 | The right of modification includes the right to translate, adapt, 200 | arrange, or make any or all modifications to the Software, and the right 201 | to reproduce the resulting software. It includes, in particular, the 202 | right to create a Derivative Software. 203 | 204 | The Licensee is authorized to make any or all modification to the 205 | Software provided that it includes an explicit notice that it is the 206 | author of said modification and indicates the date of the creation thereof. 207 | 208 | 209 | 5.3 RIGHT OF DISTRIBUTION 210 | 211 | In particular, the right of distribution includes the right to publish, 212 | transmit and communicate the Software to the general public on any or 213 | all medium, and by any or all means, and the right to market, either in 214 | consideration of a fee, or free of charge, one or more copies of the 215 | Software by any means. 216 | 217 | The Licensee is further authorized to distribute copies of the modified 218 | or unmodified Software to third parties according to the terms and 219 | conditions set forth hereinafter. 220 | 221 | 222 | 5.3.1 DISTRIBUTION OF SOFTWARE WITHOUT MODIFICATION 223 | 224 | The Licensee is authorized to distribute true copies of the Software in 225 | Source Code or Object Code form, provided that said distribution 226 | complies with all the provisions of the Agreement and is accompanied by: 227 | 228 | 1. a copy of the Agreement, 229 | 230 | 2. a notice relating to the limitation of both the Licensor's 231 | warranty and liability as set forth in Articles 8 and 9, 232 | 233 | and that, in the event that only the Object Code of the Software is 234 | redistributed, the Licensee allows effective access to the full Source 235 | Code of the Software at a minimum during the entire period of its 236 | distribution of the Software, it being understood that the additional 237 | cost of acquiring the Source Code shall not exceed the cost of 238 | transferring the data. 239 | 240 | 241 | 5.3.2 DISTRIBUTION OF MODIFIED SOFTWARE 242 | 243 | When the Licensee makes an Integrated Contribution to the Software, the 244 | terms and conditions for the distribution of the resulting Modified 245 | Software become subject to all the provisions of this Agreement. 246 | 247 | The Licensee is authorized to distribute the Modified Software, in 248 | source code or object code form, provided that said distribution 249 | complies with all the provisions of the Agreement and is accompanied by: 250 | 251 | 1. a copy of the Agreement, 252 | 253 | 2. a notice relating to the limitation of both the Licensor's 254 | warranty and liability as set forth in Articles 8 and 9, 255 | 256 | and that, in the event that only the object code of the Modified 257 | Software is redistributed, the Licensee allows effective access to the 258 | full source code of the Modified Software at a minimum during the entire 259 | period of its distribution of the Modified Software, it being understood 260 | that the additional cost of acquiring the source code shall not exceed 261 | the cost of transferring the data. 262 | 263 | 264 | 5.3.3 DISTRIBUTION OF DERIVATIVE SOFTWARE 265 | 266 | When the Licensee creates Derivative Software, this Derivative Software 267 | may be distributed under a license agreement other than this Agreement, 268 | subject to compliance with the requirement to include a notice 269 | concerning the rights over the Software as defined in Article 6.4. 270 | In the event the creation of the Derivative Software required modification 271 | of the Source Code, the Licensee undertakes that: 272 | 273 | 1. the resulting Modified Software will be governed by this Agreement, 274 | 2. the Integrated Contributions in the resulting Modified Software 275 | will be clearly identified and documented, 276 | 3. the Licensee will allow effective access to the source code of the 277 | Modified Software, at a minimum during the entire period of 278 | distribution of the Derivative Software, such that such 279 | modifications may be carried over in a subsequent version of the 280 | Software; it being understood that the additional cost of 281 | purchasing the source code of the Modified Software shall not 282 | exceed the cost of transferring the data. 283 | 284 | 285 | 5.3.4 COMPATIBILITY WITH THE CeCILL LICENSE 286 | 287 | When a Modified Software contains an Integrated Contribution subject to 288 | the CeCILL license agreement, or when a Derivative Software contains a 289 | Related Module subject to the CeCILL license agreement, the provisions 290 | set forth in the third item of Article 6.4 are optional. 291 | 292 | 293 | Article 6 - INTELLECTUAL PROPERTY 294 | 295 | 296 | 6.1 OVER THE INITIAL SOFTWARE 297 | 298 | The Holder owns the economic rights over the Initial Software. Any or 299 | all use of the Initial Software is subject to compliance with the terms 300 | and conditions under which the Holder has elected to distribute its work 301 | and no one shall be entitled to modify the terms and conditions for the 302 | distribution of said Initial Software. 303 | 304 | The Holder undertakes that the Initial Software will remain ruled at 305 | least by this Agreement, for the duration set forth in Article 4.2. 306 | 307 | 308 | 6.2 OVER THE INTEGRATED CONTRIBUTIONS 309 | 310 | The Licensee who develops an Integrated Contribution is the owner of the 311 | intellectual property rights over this Contribution as defined by 312 | applicable law. 313 | 314 | 315 | 6.3 OVER THE RELATED MODULES 316 | 317 | The Licensee who develops a Related Module is the owner of the 318 | intellectual property rights over this Related Module as defined by 319 | applicable law and is free to choose the type of agreement that shall 320 | govern its distribution under the conditions defined in Article 5.3.3. 321 | 322 | 323 | 6.4 NOTICE OF RIGHTS 324 | 325 | The Licensee expressly undertakes: 326 | 327 | 1. not to remove, or modify, in any manner, the intellectual property 328 | notices attached to the Software; 329 | 330 | 2. to reproduce said notices, in an identical manner, in the copies 331 | of the Software modified or not; 332 | 333 | 3. to ensure that use of the Software, its intellectual property 334 | notices and the fact that it is governed by the Agreement is 335 | indicated in a text that is easily accessible, specifically from 336 | the interface of any Derivative Software. 337 | 338 | The Licensee undertakes not to directly or indirectly infringe the 339 | intellectual property rights of the Holder and/or Contributors on the 340 | Software and to take, where applicable, vis-�-vis its staff, any and all 341 | measures required to ensure respect of said intellectual property rights 342 | of the Holder and/or Contributors. 343 | 344 | 345 | Article 7 - RELATED SERVICES 346 | 347 | 7.1 Under no circumstances shall the Agreement oblige the Licensor to 348 | provide technical assistance or maintenance services for the Software. 349 | 350 | However, the Licensor is entitled to offer this type of services. The 351 | terms and conditions of such technical assistance, and/or such 352 | maintenance, shall be set forth in a separate instrument. Only the 353 | Licensor offering said maintenance and/or technical assistance services 354 | shall incur liability therefor. 355 | 356 | 7.2 Similarly, any Licensor is entitled to offer to its licensees, under 357 | its sole responsibility, a warranty, that shall only be binding upon 358 | itself, for the redistribution of the Software and/or the Modified 359 | Software, under terms and conditions that it is free to decide. Said 360 | warranty, and the financial terms and conditions of its application, 361 | shall be subject of a separate instrument executed between the Licensor 362 | and the Licensee. 363 | 364 | 365 | Article 8 - LIABILITY 366 | 367 | 8.1 Subject to the provisions of Article 8.2, the Licensee shall be 368 | entitled to claim compensation for any direct loss it may have suffered 369 | from the Software as a result of a fault on the part of the relevant 370 | Licensor, subject to providing evidence thereof. 371 | 372 | 8.2 The Licensor's liability is limited to the commitments made under 373 | this Agreement and shall not be incurred as a result of in particular: 374 | (i) loss due the Licensee's total or partial failure to fulfill its 375 | obligations, (ii) direct or consequential loss that is suffered by the 376 | Licensee due to the use or performance of the Software, and (iii) more 377 | generally, any consequential loss. In particular the Parties expressly 378 | agree that any or all pecuniary or business loss (i.e. loss of data, 379 | loss of profits, operating loss, loss of customers or orders, 380 | opportunity cost, any disturbance to business activities) or any or all 381 | legal proceedings instituted against the Licensee by a third party, 382 | shall constitute consequential loss and shall not provide entitlement to 383 | any or all compensation from the Licensor. 384 | 385 | 386 | Article 9 - WARRANTY 387 | 388 | 9.1 The Licensee acknowledges that the scientific and technical 389 | state-of-the-art when the Software was distributed did not enable all 390 | possible uses to be tested and verified, nor for the presence of 391 | possible defects to be detected. In this respect, the Licensee's 392 | attention has been drawn to the risks associated with loading, using, 393 | modifying and/or developing and reproducing the Software which are 394 | reserved for experienced users. 395 | 396 | The Licensee shall be responsible for verifying, by any or all means, 397 | the suitability of the product for its requirements, its good working 398 | order, and for ensuring that it shall not cause damage to either persons 399 | or properties. 400 | 401 | 9.2 The Licensor hereby represents, in good faith, that it is entitled 402 | to grant all the rights over the Software (including in particular the 403 | rights set forth in Article 5). 404 | 405 | 9.3 The Licensee acknowledges that the Software is supplied "as is" by 406 | the Licensor without any other express or tacit warranty, other than 407 | that provided for in Article 9.2 and, in particular, without any warranty 408 | as to its commercial value, its secured, safe, innovative or relevant 409 | nature. 410 | 411 | Specifically, the Licensor does not warrant that the Software is free 412 | from any error, that it will operate without interruption, that it will 413 | be compatible with the Licensee's own equipment and software 414 | configuration, nor that it will meet the Licensee's requirements. 415 | 416 | 9.4 The Licensor does not either expressly or tacitly warrant that the 417 | Software does not infringe any third party intellectual property right 418 | relating to a patent, software or any other property right. Therefore, 419 | the Licensor disclaims any and all liability towards the Licensee 420 | arising out of any or all proceedings for infringement that may be 421 | instituted in respect of the use, modification and redistribution of the 422 | Software. Nevertheless, should such proceedings be instituted against 423 | the Licensee, the Licensor shall provide it with technical and legal 424 | assistance for its defense. Such technical and legal assistance shall be 425 | decided on a case-by-case basis between the relevant Licensor and the 426 | Licensee pursuant to a memorandum of understanding. The Licensor 427 | disclaims any and all liability as regards the Licensee's use of the 428 | name of the Software. No warranty is given as regards the existence of 429 | prior rights over the name of the Software or as regards the existence 430 | of a trademark. 431 | 432 | 433 | Article 10 - TERMINATION 434 | 435 | 10.1 In the event of a breach by the Licensee of its obligations 436 | hereunder, the Licensor may automatically terminate this Agreement 437 | thirty (30) days after notice has been sent to the Licensee and has 438 | remained ineffective. 439 | 440 | 10.2 A Licensee whose Agreement is terminated shall no longer be 441 | authorized to use, modify or distribute the Software. However, any 442 | licenses that it may have granted prior to termination of the Agreement 443 | shall remain valid subject to their having been granted in compliance 444 | with the terms and conditions hereof. 445 | 446 | 447 | Article 11 - MISCELLANEOUS 448 | 449 | 450 | 11.1 EXCUSABLE EVENTS 451 | 452 | Neither Party shall be liable for any or all delay, or failure to 453 | perform the Agreement, that may be attributable to an event of force 454 | majeure, an act of God or an outside cause, such as defective 455 | functioning or interruptions of the electricity or telecommunications 456 | networks, network paralysis following a virus attack, intervention by 457 | government authorities, natural disasters, water damage, earthquakes, 458 | fire, explosions, strikes and labor unrest, war, etc. 459 | 460 | 11.2 Any failure by either Party, on one or more occasions, to invoke 461 | one or more of the provisions hereof, shall under no circumstances be 462 | interpreted as being a waiver by the interested Party of its right to 463 | invoke said provision(s) subsequently. 464 | 465 | 11.3 The Agreement cancels and replaces any or all previous agreements, 466 | whether written or oral, between the Parties and having the same 467 | purpose, and constitutes the entirety of the agreement between said 468 | Parties concerning said purpose. No supplement or modification to the 469 | terms and conditions hereof shall be effective as between the Parties 470 | unless it is made in writing and signed by their duly authorized 471 | representatives. 472 | 473 | 11.4 In the event that one or more of the provisions hereof were to 474 | conflict with a current or future applicable act or legislative text, 475 | said act or legislative text shall prevail, and the Parties shall make 476 | the necessary amendments so as to comply with said act or legislative 477 | text. All other provisions shall remain effective. Similarly, invalidity 478 | of a provision of the Agreement, for any reason whatsoever, shall not 479 | cause the Agreement as a whole to be invalid. 480 | 481 | 482 | 11.5 LANGUAGE 483 | 484 | The Agreement is drafted in both French and English and both versions 485 | are deemed authentic. 486 | 487 | 488 | Article 12 - NEW VERSIONS OF THE AGREEMENT 489 | 490 | 12.1 Any person is authorized to duplicate and distribute copies of this 491 | Agreement. 492 | 493 | 12.2 So as to ensure coherence, the wording of this Agreement is 494 | protected and may only be modified by the authors of the License, who 495 | reserve the right to periodically publish updates or new versions of the 496 | Agreement, each with a separate number. These subsequent versions may 497 | address new issues encountered by Free Software. 498 | 499 | 12.3 Any Software distributed under a given version of the Agreement may 500 | only be subsequently distributed under the same version of the Agreement 501 | or a subsequent version. 502 | 503 | 504 | Article 13 - GOVERNING LAW AND JURISDICTION 505 | 506 | 13.1 The Agreement is governed by French law. The Parties agree to 507 | endeavor to seek an amicable solution to any disagreements or disputes 508 | that may arise during the performance of the Agreement. 509 | 510 | 13.2 Failing an amicable solution within two (2) months as from their 511 | occurrence, and unless emergency proceedings are necessary, the 512 | disagreements or disputes shall be referred to the Paris Courts having 513 | jurisdiction, by the more diligent Party. 514 | 515 | 516 | Version 1.0 dated 2006-09-05. 517 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | include config 2 | 3 | .PHONY: lib examples test 4 | 5 | all: lib 6 | 7 | config: 8 | ./configure 9 | 10 | install: lib 11 | mkdir -p $(LIBDIR) 12 | cp lib/* $(LIBDIR) 13 | $(OCAMLFIND) install websocketml META 14 | 15 | lib: config 16 | $(MAKE) -C src 17 | mkdir -p lib 18 | cp src/*.cmi src/*.cma src/*.cmxa src/*.a lib 19 | 20 | doc: lib 21 | mkdir -p docs 22 | ocamldoc $(OCAMLFLAGS) -html -d docs -css-style css/doc_style.css -verbose \ 23 | -hide Stdlib,Websocketml.Http,Ws,Sha1,Base64,Utils \ 24 | -t websocketml -show-missed-crossref -charset utf8 -short-functors \ 25 | -short-paths \ 26 | -I src \ 27 | src/websocketml.mli src/websocketml.ml 28 | 29 | examples: lib 30 | $(MAKE) -C examples 31 | 32 | test: lib 33 | $(MAKE) -C test run 34 | 35 | clean: 36 | $(MAKE) -C src clean 37 | $(MAKE) -C examples clean 38 | $(MAKE) -C test clean 39 | 40 | cleanall realclean mrproper: clean 41 | $(MAKE) -C src cleanall 42 | $(MAKE) -C examples cleanall 43 | $(MAKE) -C test cleanall 44 | rm -rf lib 45 | rm -f config META opam 46 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # websocketml 2 | A simple websocket library for OCaml with no dependencies. 3 | 4 | [Documentation](https://ismailbennani.github.io/websocketml/) 5 | 6 | ## Install using `opam` 7 | 8 | From opam repo: 9 | ``` 10 | opam install websocketml 11 | ``` 12 | 13 | From this repo: 14 | ``` 15 | cd /path/to/websocketml 16 | opam install . 17 | ``` 18 | 19 | ## Simple example 20 | 21 | Run a simple server 22 | ``` 23 | cd /path/to/websocketml 24 | make 25 | make examples 26 | cd examples/echo 27 | ./echo_server.byte 28 | ``` 29 | 30 | Then open `examples/echo/echo_client.html` in your favorite browser (with javascript enabled) 31 | -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | prefix=/usr/local 4 | version=0.1.1 5 | 6 | while : ; do 7 | case "$1" in 8 | "") break;; 9 | 10 | --prefix) 11 | prefix=$2; shift;; 12 | --prefix=*) 13 | prefix=`expr "$1" : '--[^=]*=\(.*\)'`;; 14 | esac 15 | shift 16 | done 17 | 18 | cat > config < META < 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | websocketml : Websocketml.Http 15 | 16 | 17 |
 Up 18 |  Next 19 |
20 |

Module Websocketml.Http

21 | 22 | 
module Http: sig .. end
23 |
24 |

Implement a subset of HTTP/1.1 RFC2616. 25 | Its only purpose is to do a websocket handshake, it cannot be used as 26 | regular HTTP server. One could use any other mean to retrieve an open 27 | socket and client address to use as inputs of Websocketml.create.

28 |
29 |
30 |
31 | 32 | 
exception HTTPError of string
33 | 34 | 
type t
35 | 36 | 37 | 
val create : Unix.sockaddr -> t
38 |
39 |

Create a TCP socket and bind it to given address

40 |
41 |
42 | 43 | 
val listen : t -> unit
44 |
45 |

Set up the socket for receiving connection requests 46 | (with a pending list of size 1)

47 |
48 |
49 | 50 | 
val accept : t -> Unix.file_descr * Unix.sockaddr
51 |
52 |

Block until a connection is received and return the socket and address 53 | of the connecting client

54 |
55 |
56 | 57 | 
val listen_and_accept : t -> Unix.file_descr * Unix.sockaddr
58 |
59 |

Call listen then accept

60 |
61 |
62 | 63 | 
val do_ws_handshake : Unix.file_descr -> unit
64 |
65 |

Read a WebSocket opening request on the given socket and answer with 66 | an appropriate message to complete the handshake defined 67 | by RFC6455.

68 | 69 |

Raise HTTPError if the received request is not a valid HTTP request or 70 | if it is not a valid WebSocket opening request.

71 |
72 |
73 | 74 | 
val close : t -> unit
75 |
76 |

Close the server's TCP socket

77 |
78 |
79 | 80 | 
val to_string : t -> string
81 | 
val print_t : out_channel -> t -> unit
82 | -------------------------------------------------------------------------------- /docs/Websocketml.Logger.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | websocketml : Websocketml.Logger 15 | 16 | 17 |
Previous 18 |  Up 19 |  
20 |

Module Websocketml.Logger

21 | 22 | 
module Logger: sig .. end
23 |
24 |

usage example:

25 | 
Logger.info (fun f -> f "[%s] %d" some_string some_int)
26 |
27 |
28 | 29 | 
type verbose =
30 | 31 | 33 | 35 | 36 | 37 | 38 | 40 | 42 | 43 | 44 | 45 | 47 | 49 | 50 | 51 | 52 | 54 | 56 | 57 |
32 | | 34 | ERROR
39 | | 41 | WARN
46 | | 48 | INFO
53 | | 55 | DEBUG
58 | 59 | 60 | 61 | 
val set_verbose : verbose -> unit
62 | 
val error : ((('a, out_channel, unit) format -> 'a) -> 'b) -> unit
63 | 
val warn : ((('a, out_channel, unit) format -> 'a) -> 'b) -> unit
64 | 
val info : ((('a, out_channel, unit) format -> 'a) -> 'b) -> unit
65 | 
val debug : ((('a, out_channel, unit) format -> 'a) -> 'b) -> unit
66 | -------------------------------------------------------------------------------- /docs/Websocketml.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | websocketml : Websocketml 20 | 21 | 22 |
 Up 23 |  
24 |

Module Websocketml

25 | 26 | 
module Websocketml: sig .. end
27 |
28 |

This library implements RFC6455. 29 | There are currently no supported extensions.

30 |
31 |
32 |
33 |

WS

34 | 
exception WSError of string
35 | 36 | 
type t
37 | 38 | 39 | 
type msg_type =
40 | 41 | 43 | 45 | 46 | 47 | 48 | 50 | 52 | 53 |
42 | | 44 | BinaryMsg
49 | | 51 | TextMsg
54 | 55 | 56 | 57 | 
type msg = {
58 | 59 | 61 | 63 | 64 | 65 | 66 | 68 | 70 | 71 |
60 |    62 | msg_typ : msg_type;
67 |    69 | msg_data : bytes;
72 | } 73 | 74 | 75 | 76 | 
type opcode =
77 | 78 | 80 | 82 | 83 | 84 | 85 | 87 | 89 | 90 | 91 | 92 | 94 | 96 | 97 | 98 | 99 | 101 | 103 | 104 | 105 | 106 | 108 | 110 | 111 | 112 | 113 | 115 | 117 | 118 | 119 | 120 | 122 | 124 | 125 | 126 | 127 | 129 | 131 | 132 |
79 | | 81 | ContinuationFrame
86 | | 88 | TextFrame
93 | | 95 | BinaryFrame
100 | | 102 | Close
107 | | 109 | Ping
114 | | 116 | Pong
121 | | 123 | ControlFrame of int
128 | | 130 | NonControlFrame of int
133 | 134 |
135 |
136 |

All these op codes are defined in the RFC

137 |
138 |
139 | 140 | 141 | 
type exit_code =
142 | 143 | 145 | 147 | 153 | 154 | 155 | 157 | 159 | 165 | 166 | 167 | 169 | 171 | 177 | 178 | 179 | 181 | 183 | 189 | 190 | 191 | 193 | 195 | 201 | 202 | 203 | 205 | 207 | 213 | 214 | 215 | 217 | 219 | 225 | 226 | 227 | 229 | 231 | 237 | 238 | 239 | 241 | 243 | 249 | 250 | 251 | 253 | 255 | 261 | 262 | 263 | 265 | 267 | 273 | 274 | 275 | 277 | 279 | 285 | 286 | 287 | 289 | 291 | 300 | 301 | 302 | 304 | 306 | 312 |
144 | | 146 | NormalClosure(*
148 |
149 |

1000

150 |
151 |
152 | 		*)
156 | | 158 | GoingAway(*
160 |
161 |

1001

162 |
163 |
164 | 		*)
168 | | 170 | ProtocolError(*
172 |
173 |

1002

174 |
175 |
176 | 		*)
180 | | 182 | UnkownDatatype(*
184 |
185 |

1003

186 |
187 |
188 | 		*)
192 | | 194 | NoStatusCode(*
196 |
197 |

1005

198 |
199 |
200 | 		*)
204 | | 206 | AbnormalClosure(*
208 |
209 |

1006

210 |
211 |
212 | 		*)
216 | | 218 | InconsistentData(*
220 |
221 |

1007

222 |
223 |
224 | 		*)
228 | | 230 | PolicyViolation(*
232 |
233 |

1008

234 |
235 |
236 | 		*)
240 | | 242 | MsgTooBig(*
244 |
245 |

1009

246 |
247 |
248 | 		*)
252 | | 254 | RequiredExtension(*
256 |
257 |

1010

258 |
259 |
260 | 		*)
264 | | 266 | UnexpectedCondition(*
268 |
269 |

1011

270 |
271 |
272 | 		*)
276 | | 278 | TLSFailure(*
280 |
281 |

1015

282 |
283 |
284 | 		*)
288 | | 290 | ReservedCode of int(*
292 |
293 |

ranges : 294 | 0 - 999 : not used 295 | 1000 - 2999 : reserved for websocket protocol 296 | 3000 - 3999 : reserved for public libraries

297 |
298 |
299 | 		*)
303 | | 305 | CustomCode of int(*
307 |
308 |

range 4000 - 4999 : private use

309 |
310 |
311 | 		*)
313 | 314 |
315 |
316 |

All these exit codes are defined in the RFC

317 |
318 |
319 | 320 | 321 | 
val create : Unix.file_descr * Unix.sockaddr -> t
322 |
323 |

Create a new connexion.

324 | 325 |

WARNING: this method assumes that the socket is already open and that 326 | the WebSocket handshake has already been performed. Refer to 327 | create, listen_and_accept and 328 | do_ws_handshake methods of module Websocketml.Http.

329 |
330 |
331 | 332 | 
val get_sock : t -> Unix.file_descr
333 |
334 |

Get the unix socket

335 |
336 |
337 | 338 | 
val get_addr : t -> Unix.sockaddr
339 |
340 |

Get remote address

341 |
342 |
343 |

Read

344 | 
val receive_message : t -> msg option
345 |
346 |

Block until a complete message is received. This method may read several 347 | frames in a single call until it reaches the final frame of the message.

348 | 349 |

If the received frame is a Close frame, it closes the connection and returns 350 | None.

351 | 352 |

If the received frame is a Ping, it answers with an appropriate Pong and 353 | returns None.

354 | 355 |

If the received frame is a Pong, it outputs a debug message and returns 356 | None.

357 | 358 |

Raise Websocketml.WSError if the socket is closed or if the received message is 359 | ill-formed.

360 |
361 |
362 |

Write

These method may raise Websocketml.WSError if the socket is closed

363 | 364 | 
val send_msg : t -> opcode -> bytes -> int
365 | 
val send_ping : t -> bytes -> int
366 | 
val send_text : t -> string -> int
367 | 
val send_binary : t -> bytes -> int
368 | 
val close : t -> exit_code -> int
369 | 
val close_with_message : t -> exit_code -> string -> int

Helpers

370 | 
val closed_in : t -> bool
371 |
372 |

Return true if the socket cannot be read from

373 |
374 |
375 | 376 | 
val closed_out : t -> bool
377 |
378 |

Return true if the socket cannot be written to

379 |
380 |
381 | 382 | 
val closed : t -> bool
383 |
384 |

Return true if the socket cannot be read from or written to

385 |
386 |
387 | 388 | 
val to_string : t -> string
389 | 
val print_t : out_channel -> t -> unit

HTTP

390 | 
module Http: sig .. end
391 |

Implement a subset of HTTP/1.1 RFC2616.

392 | 393 |
394 |

Logger

395 | 
module Logger: sig .. end
396 |

usage example:

397 | 
Logger.info (fun f -> f "[%s] %d" some_string some_int)
398 |
399 | 400 | -------------------------------------------------------------------------------- /docs/css/colors.css: -------------------------------------------------------------------------------- 1 | :root { 2 | /* 3 | 4 | taken from one-light-syntax theme of Atom 5 | https://github.com/atom/one-light-syntax/blob/master/styles/colors.less 6 | 7 | */ 8 | 9 | 10 | /* Config ----------------------------------- */ 11 | --syntax-hue: 230; 12 | --syntax-saturation: 1%; 13 | --syntax-brightness: 95%; 14 | 15 | 16 | /* Monochrome ----------------------------------- */ 17 | --mono-1: hsl(var(--syntax-hue), 8%, 24%); 18 | --mono-2: hsl(var(--syntax-hue), 6%, 44%); 19 | --mono-3: hsl(var(--syntax-hue), 4%, 64%); 20 | 21 | /* Colors ----------------------------------- */ 22 | --hue-1: hsl(198, 99%, 37%); /* <-cyan */ 23 | --hue-2: hsl(221, 87%, 60%); /* <-blue */ 24 | --hue-3: hsl(301, 63%, 40%); /* <-purple */ 25 | --hue-4: hsl(119, 34%, 47%); /* <-green */ 26 | 27 | --hue-5: hsl( 5, 74%, 59%); /* <-red 1 */ 28 | --hue-5-2: hsl(344, 84%, 43%); /* <-red 2 */ 29 | 30 | --hue-6: hsl(41, 99%, 30%); /* <-orange 1 */ 31 | --hue-6-2: hsl(41, 99%, 38%); /* <-orange 2 */ 32 | 33 | /* Base colors ----------------------------------- */ 34 | --syntax-fg: var(--mono-1); 35 | --syntax-bg: hsl(var(--syntax-hue), var(--syntax-saturation), var(--syntax-brightness)); 36 | } 37 | -------------------------------------------------------------------------------- /docs/css/doc_style.css: -------------------------------------------------------------------------------- 1 | /* CSS file mostly copied from the official OCaml documentation */ 2 | 3 | @import url("colors.css"); 4 | 5 | /* fira-sans-regular - latin */ 6 | @font-face { 7 | font-family: 'Fira Sans'; 8 | font-style: normal; 9 | font-weight: 400; 10 | src: url('../fonts/fira-sans-v8-latin-regular.eot'); /* IE9 Compat Modes */ 11 | src: local('Fira Sans Regular'), local('FiraSans-Regular'), 12 | url('../fonts/fira-sans-v8-latin-regular.eot?#iefix') format('embedded-opentype'), /* IE6-IE8 */ 13 | url('../fonts/fira-sans-v8-latin-regular.woff2') format('woff2'), /* Super Modern Browsers */ 14 | url('../fonts/fira-sans-v8-latin-regular.woff') format('woff'), /* Modern Browsers */ 15 | url('../fonts/fira-sans-v8-latin-regular.ttf') format('truetype'), /* Safari, Android, iOS */ 16 | url('../fonts/fira-sans-v8-latin-regular.svg#FiraSans') format('svg'); /* Legacy iOS */ 17 | } 18 | 19 | 20 | a:visited {color : #416DFF; text-decoration : none; } 21 | a:link {color : #416DFF; text-decoration : none; } 22 | a:hover {color : Black; text-decoration : underline; } 23 | a:active {color : Black; text-decoration : underline; } 24 | .keyword { font-weight : bold ; color : var(--hue-3) } 25 | .keywordsign { color : #C04600 } 26 | .comment { color : var(--mono-2) } 27 | .constructor { color : var(--hue-6-2); font-weight: bold; } 28 | .type { color : #5C6585 } 29 | .string { color : var(--hue-6) } 30 | .warning { color : Red ; font-weight : bold } 31 | .info { margin-left : 3em; margin-right : 3em } 32 | .code { color : #465F91 ; } 33 | h1 { font-size : 2rem ; text-align: center; } 34 | 35 | h2, h3, h4, h5, h6, div.h7, div.h8, div.h9 { 36 | font-size: 1.75rem; 37 | border: 1px solid #000; 38 | margin-top: 20px; 39 | margin-bottom: 2px; 40 | text-align: center; 41 | padding: 8px; 42 | font-family: "Fira Sans", sans-serif; 43 | font-weight: normal; 44 | } 45 | 46 | h1 { 47 | font-family: "Fira Sans", sans-serif; 48 | padding: 10px; 49 | } 50 | 51 | h2 { background-color: #90BDFF; } 52 | h3 { background-color: #90DDFF; } 53 | h4 { background-color: #90EDFF; } 54 | h5 { background-color: #90FDFF; } 55 | h6 { background-color: #90BDFF; } 56 | div.h7 { background-color: #90DDFF; } 57 | div.h8 { background-color: #F0FFFF; } 58 | div.h9 { background-color: #FFFFFF; } 59 | 60 | .typetable { border-style : hidden } 61 | .paramstable { border-style : hidden ; padding: 5pt 5pt} 62 | body { 63 | font-size: 1rem; 64 | max-width: 800px; 65 | width: 85%; 66 | margin: auto; 67 | padding-bottom: 30px; 68 | } 69 | td { 70 | font-size: 1rem; 71 | } 72 | .navbar { /* previous - up - next */ 73 | position: absolute; 74 | left: 10px; 75 | top: 10px; 76 | } 77 | pre { margin-bottom: 4px; white-space: pre-wrap; } 78 | div.sig_block {margin-left: 2em} 79 | ul.info-attributes { list-style: none; margin: 0; padding: 0; } 80 | div.info > p:first-child{ margin-top:0; } 81 | div.info-desc > p:first-child { margin-top:0; margin-bottom:0; } 82 | 83 | .indextable { 84 | margin-top:10%; 85 | border-style : hidden; 86 | border-collapse: collapse; 87 | width: 100%; 88 | } 89 | 90 | .indextable tr { 91 | border-bottom: 1px solid #ccc; 92 | } 93 | .indextable tr td { 94 | vertical-align: middle; 95 | padding-top:10px; 96 | padding-bottom:10px; 97 | } 98 | .indextable tr td .info p { 99 | padding:0; 100 | margin:0; 101 | } 102 | .indextable tr td:first-child:before { 103 | content:"> "; 104 | } 105 | .indextable tr td:first-child { 106 | width:20%; 107 | } 108 | 109 | .indexlist { 110 | padding:0; 111 | } 112 | 113 | .indexlist li { 114 | display: inline-block; 115 | margin-left: 20px; 116 | margin-right: 20px; 117 | } 118 | 119 | .author { 120 | display: none; 121 | } 122 | -------------------------------------------------------------------------------- /docs/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | websocketml 13 | 14 | 15 |

websocketml

16 |
17 | 23 |
24 | 25 | 26 | 31 |
Websocketml
27 |

This library implements RFC6455.

28 | 29 |
30 |
32 | 33 | 34 | -------------------------------------------------------------------------------- /docs/index_attributes.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | websocketml : Index of class attributes 12 | 13 | 14 |
 Up 15 |  
16 |

Index of class attributes

17 | 18 |
19 | 20 | 21 | -------------------------------------------------------------------------------- /docs/index_class_types.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | websocketml : Index of class types 12 | 13 | 14 |
 Up 15 |  
16 |

Index of class types

17 | 18 |
19 | 20 | 21 | -------------------------------------------------------------------------------- /docs/index_classes.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | websocketml : Index of classes 12 | 13 | 14 |
 Up 15 |  
16 |

Index of classes

17 | 18 |
19 | 20 | 21 | -------------------------------------------------------------------------------- /docs/index_exceptions.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | websocketml : Index of exceptions 12 | 13 | 14 |
 Up 15 |  
16 |

Index of exceptions

17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 |
H
HTTPError [Websocketml.Http]
W
WSError [Websocketml]
25 | 26 | 27 | -------------------------------------------------------------------------------- /docs/index_extensions.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | websocketml : Index of extensions 12 | 13 | 14 |
 Up 15 |  
16 |

Index of extensions

17 | 18 |
19 | 20 | 21 | -------------------------------------------------------------------------------- /docs/index_methods.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | websocketml : Index of class methods 12 | 13 | 14 |
 Up 15 |  
16 |

Index of class methods

17 | 18 |
19 | 20 | 21 | -------------------------------------------------------------------------------- /docs/index_module_types.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | websocketml : Index of module types 12 | 13 | 14 |
 Up 15 |  
16 |

Index of module types

17 | 18 |
19 | 20 | 21 | -------------------------------------------------------------------------------- /docs/index_modules.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | websocketml : Index of modules 12 | 13 | 14 |
 Up 15 |  
16 |

Index of modules

17 | 18 | 19 | 20 | 25 | 26 | 27 | 32 | 33 | 34 | 39 |
H
Http [Websocketml]
21 |

Implement a subset of HTTP/1.1 RFC2616.

22 | 23 |
24 |
L
Logger [Websocketml]
28 |

usage example:

29 | 
Logger.info (fun f -> f "[%s] %d" some_string some_int)
30 |
31 |
W
Websocketml
35 |

This library implements RFC6455.

36 | 37 |
38 |
40 | 41 | 42 | -------------------------------------------------------------------------------- /docs/index_types.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | websocketml : Index of types 12 | 13 | 14 |
 Up 15 |  
16 |

Index of types

17 | 18 | 19 | 20 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 |
E
exit_code [Websocketml]
21 |

All these exit codes are defined in the RFC

22 | 23 |
24 |
M
msg [Websocketml]
msg_type [Websocketml]
O
opcode [Websocketml]
33 |

All these op codes are defined in the RFC

34 | 35 |
36 |
T
t [Websocketml.Http]
t [Websocketml]
V
verbose [Websocketml.Logger]
46 | 47 | 48 | -------------------------------------------------------------------------------- /docs/index_values.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | websocketml : Index of values 12 | 13 | 14 |
 Up 15 |  
16 |

Index of values

17 | 18 | 19 | 20 | 26 | 27 | 28 | 33 | 34 | 35 | 36 | 37 | 38 | 43 | 44 | 49 | 50 | 55 | 56 | 61 | 62 | 67 | 68 | 69 | 70 | 71 | 78 | 79 | 80 | 81 | 82 | 83 | 88 | 89 | 94 | 95 | 96 | 97 | 98 | 99 | 105 | 106 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 |
A
accept [Websocketml.Http]
21 |

Block until a connection is received and return the socket and address 22 | of the connecting client

23 | 24 |
25 |
C
close [Websocketml.Http]
29 |

Close the server's TCP socket

30 | 31 |
32 |
close [Websocketml]
close_with_message [Websocketml]
closed [Websocketml]
39 |

Return true if the socket cannot be read from or written to

40 | 41 |
42 |
closed_in [Websocketml]
45 |

Return true if the socket cannot be read from

46 | 47 |
48 |
closed_out [Websocketml]
51 |

Return true if the socket cannot be written to

52 | 53 |
54 |
create [Websocketml.Http]
57 |

Create a TCP socket and bind it to given address

58 | 59 |
60 |
create [Websocketml]
63 |

Create a new connexion.

64 | 65 |
66 |
D
debug [Websocketml.Logger]
do_ws_handshake [Websocketml.Http]
72 |

Read a WebSocket opening request on the given socket and answer with 73 | an appropriate message to complete the handshake defined 74 | by RFC6455.

75 | 76 |
77 |
E
error [Websocketml.Logger]
G
get_addr [Websocketml]
84 |

Get remote address

85 | 86 |
87 |
get_sock [Websocketml]
90 |

Get the unix socket

91 | 92 |
93 |
I
info [Websocketml.Logger]
L
listen [Websocketml.Http]
100 |

Set up the socket for receiving connection requests 101 | (with a pending list of size 1)

102 | 103 |
104 |
listen_and_accept [Websocketml.Http]
107 |

Call listen then accept

108 | 109 |
110 |
P
print_t [Websocketml.Http]
print_t [Websocketml]
R
receive_message [Websocketml]
119 |

Block until a complete message is received.

120 | 121 |
122 |
S
send_binary [Websocketml]
send_msg [Websocketml]
send_ping [Websocketml]
send_text [Websocketml]
set_verbose [Websocketml.Logger]
T
to_string [Websocketml.Http]
to_string [Websocketml]
W
warn [Websocketml.Logger]
143 | 144 | 145 | -------------------------------------------------------------------------------- /docs/type_Websocketml.Http.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | websocketml : Websocketml.Http 11 | 12 | 13 | sig
14 |   exception HTTPError of string
15 |   type t
16 |   val create : Unix.sockaddr -> Websocketml.Http.t
17 |   val listen : Websocketml.Http.t -> unit
18 |   val accept : Websocketml.Http.t -> Unix.file_descr * Unix.sockaddr
19 |   val listen_and_accept :
20 |     Websocketml.Http.t -> Unix.file_descr * Unix.sockaddr
21 |   val do_ws_handshake : Unix.file_descr -> unit
22 |   val close : Websocketml.Http.t -> unit
23 |   val to_string : Websocketml.Http.t -> string
24 |   val print_t : Stdlib.out_channel -> Websocketml.Http.t -> unit
25 | end 26 | -------------------------------------------------------------------------------- /docs/type_Websocketml.Logger.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | websocketml : Websocketml.Logger 11 | 12 | 13 | sig
14 |   type verbose = ERROR | WARN | INFO | DEBUG
15 |   val set_verbose : Websocketml.Logger.verbose -> unit
16 |   val error :
17 |     ((('a, Stdlib.out_channel, unit) Stdlib.format -> 'a) -> 'b) -> unit
18 |   val warn :
19 |     ((('a, Stdlib.out_channel, unit) Stdlib.format -> 'a) -> 'b) -> unit
20 |   val info :
21 |     ((('a, Stdlib.out_channel, unit) Stdlib.format -> 'a) -> 'b) -> unit
22 |   val debug :
23 |     ((('a, Stdlib.out_channel, unit) Stdlib.format -> 'a) -> 'b) -> unit
24 | end 25 | -------------------------------------------------------------------------------- /docs/type_Websocketml.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | websocketml : Websocketml 11 | 12 | 13 | sig
14 |   exception WSError of string
15 |   type t
16 |   type msg_type = BinaryMsg | TextMsg
17 |   type msg = { msg_typ : Websocketml.msg_type; msg_data : bytes; }
18 |   type opcode =
19 |       ContinuationFrame
20 |     | TextFrame
21 |     | BinaryFrame
22 |     | Close
23 |     | Ping
24 |     | Pong
25 |     | ControlFrame of int
26 |     | NonControlFrame of int
27 |   type exit_code =
28 |       NormalClosure
29 |     | GoingAway
30 |     | ProtocolError
31 |     | UnkownDatatype
32 |     | NoStatusCode
33 |     | AbnormalClosure
34 |     | InconsistentData
35 |     | PolicyViolation
36 |     | MsgTooBig
37 |     | RequiredExtension
38 |     | UnexpectedCondition
39 |     | TLSFailure
40 |     | ReservedCode of int
41 |     | CustomCode of int
42 |   val create : Unix.file_descr * Unix.sockaddr -> Websocketml.t
43 |   val get_sock : Websocketml.t -> Unix.file_descr
44 |   val get_addr : Websocketml.t -> Unix.sockaddr
45 |   val receive_message : Websocketml.t -> Websocketml.msg option
46 |   val send_msg : Websocketml.t -> Websocketml.opcode -> bytes -> int
47 |   val send_ping : Websocketml.t -> bytes -> int
48 |   val send_text : Websocketml.t -> string -> int
49 |   val send_binary : Websocketml.t -> bytes -> int
50 |   val close : Websocketml.t -> Websocketml.exit_code -> int
51 |   val close_with_message :
52 |     Websocketml.t -> Websocketml.exit_code -> string -> int
53 |   val closed_in : Websocketml.t -> bool
54 |   val closed_out : Websocketml.t -> bool
55 |   val closed : Websocketml.t -> bool
56 |   val to_string : Websocketml.t -> string
57 |   val print_t : Stdlib.out_channel -> Websocketml.t -> unit
58 |   module Http :
59 |     sig
60 |       exception HTTPError of string
61 |       type t
62 |       val create : Unix.sockaddr -> Websocketml.Http.t
63 |       val listen : Websocketml.Http.t -> unit
64 |       val accept : Websocketml.Http.t -> Unix.file_descr * Unix.sockaddr
65 |       val listen_and_accept :
66 |         Websocketml.Http.t -> Unix.file_descr * Unix.sockaddr
67 |       val do_ws_handshake : Unix.file_descr -> unit
68 |       val close : Websocketml.Http.t -> unit
69 |       val to_string : Websocketml.Http.t -> string
70 |       val print_t : Stdlib.out_channel -> Websocketml.Http.t -> unit
71 |     end
72 |   module Logger :
73 |     sig
74 |       type verbose = ERROR | WARN | INFO | DEBUG
75 |       val set_verbose : Websocketml.Logger.verbose -> unit
76 |       val error :
77 |         ((('a, Stdlib.out_channel, unit) Stdlib.format -> 'a) -> 'b) -> unit
78 |       val warn :
79 |         ((('a, Stdlib.out_channel, unit) Stdlib.format -> 'a) -> 'b) -> unit
80 |       val info :
81 |         ((('a, Stdlib.out_channel, unit) Stdlib.format -> 'a) -> 'b) -> unit
82 |       val debug :
83 |         ((('a, Stdlib.out_channel, unit) Stdlib.format -> 'a) -> 'b) -> unit
84 |     end
85 | end 86 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | $(MAKE) -C echo 3 | 4 | clean cleanall realclean: 5 | $(MAKE) -C echo clean 6 | -------------------------------------------------------------------------------- /examples/echo/Makefile: -------------------------------------------------------------------------------- 1 | include ../../config 2 | 3 | all: echo_server.byte 4 | 5 | echo_server.byte: 6 | $(OCAMLC) -o $@ unix.cma str.cma -I ../../lib websocketml.cma \ 7 | echo_server.ml 8 | 9 | clean: 10 | @rm -rf *.cm[iox] 11 | @rm -rf echo_server.byte 12 | -------------------------------------------------------------------------------- /examples/echo/echo_client.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | WebSocket Test 6 | 73 | 74 | 75 |

WebSocket Test

76 | 77 | 78 | 79 |
80 |
81 | 82 | 83 | -------------------------------------------------------------------------------- /examples/echo/echo_server.ml: -------------------------------------------------------------------------------- 1 | let msgs = [ 2 | "YOU are breathtaking!"; 3 | "YOU are breathtaking!"; 4 | "YOU are breathtaking!"; 5 | "YOU are breathtaking!"; 6 | "YOU are breathtaking!"; 7 | "YOU are breathtaking!"; 8 | "It was fun, let's stop playing now"; 9 | "We should both go back to work"; 10 | "Please, stop this"; 11 | "I'm asking you to stop pushing that button"; 12 | "Are you listening to me ?"; 13 | "Stop it already"; 14 | "I'm not answering you anymore"; 15 | "I mean it"; 16 | "Hit the DISCONNECT button"; 17 | "I will disconnect if you continue"; 18 | "Ok stop please"; 19 | "I said stop"; 20 | "Seriously ?"; 21 | "I'M OUT !!"; 22 | ] 23 | 24 | let _ = 25 | (* server on localhost *) 26 | let address = Unix.inet_addr_of_string "127.0.0.1" in 27 | let port = 8080 in 28 | let inet_addr = Unix.ADDR_INET(address, port) in 29 | 30 | (* create the small server *) 31 | let connection_server = Websocketml.Http.create inet_addr in 32 | 33 | (* wait for a connexion *) 34 | let client_sock, client_addr = Websocketml.Http.listen_and_accept connection_server in 35 | 36 | begin 37 | try 38 | (* do the websocket handshake, 39 | if there is no exception, everything is ok *) 40 | Websocketml.Http.do_ws_handshake client_sock; 41 | 42 | (* create the websocket connection *) 43 | let websock = Websocketml.create (client_sock, client_addr) in 44 | 45 | (* listen for a websocket message *) 46 | (* Note : it can be None, for example if the first frame 47 | is a CLOSE frame *) 48 | let msg = Websocketml.receive_message websock in 49 | begin match msg with 50 | | None -> () 51 | | Some msg -> 52 | (* print the message *) 53 | Websocketml.Logger.info (fun m -> m "Received message: %s" 54 | begin match msg.msg_typ with 55 | | BinaryMsg -> "binary of length " ^ (string_of_int (Bytes.length msg.msg_data)) 56 | | TextMsg -> Bytes.to_string msg.msg_data 57 | end); 58 | end; 59 | 60 | (* send something back *) 61 | let to_send = "YOU are breathtaking!" in 62 | ignore (Websocketml.send_text websock to_send); 63 | Websocketml.Logger.info (fun m -> m "Sent message : %s" to_send); 64 | 65 | (* send a ping message*) 66 | ignore (Websocketml.send_ping websock (Bytes.of_string "Hello world")); 67 | Websocketml.Logger.info (fun m -> m "Sent ping"); 68 | 69 | Websocketml.Logger.info (fun m -> m "Waiting for message"); 70 | let msg = ref (Websocketml.receive_message websock) in 71 | 72 | (* the stack of answers *) 73 | let msg_stack = ref msgs in 74 | 75 | while not (Websocketml.closed websock) && (List.length !msg_stack > 0) do 76 | 77 | (* this time we expect to get a CLOSE message, msg can be None *) 78 | begin match !msg with 79 | | None -> Websocketml.Logger.info (fun m -> m "empty message") 80 | | Some msg -> Websocketml.Logger.info (fun m -> m "Got : %s" (Bytes.to_string msg.msg_data)) 81 | end; 82 | 83 | (* send one of the answers *) 84 | let to_send = (List.hd !msg_stack) in 85 | ignore (Websocketml.send_text websock to_send); 86 | Websocketml.Logger.info (fun m -> m "Sent message : %s" to_send); 87 | msg_stack := List.tl !msg_stack; 88 | 89 | (* if there are more answers we continue listening, else we disconnect *) 90 | if List.length !msg_stack > 0 then begin 91 | Websocketml.Logger.info (fun m -> m "Waiting for message"); 92 | msg := Websocketml.receive_message websock 93 | end else 94 | ignore (Websocketml.close websock Websocketml.NormalClosure); 95 | done 96 | 97 | with e -> Websocketml.Logger.error (fun m -> m "Exception : %s" (Printexc.to_string e)) 98 | end; 99 | Websocketml.Http.close connection_server 100 | -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | include ../config 2 | 3 | define find_rec 4 | $(shell find * -name "$(1)") 5 | endef 6 | 7 | OBJ = logger.cmo \ 8 | utils.cmo \ 9 | base64.cmo \ 10 | sha1.cmo \ 11 | ws.cmo \ 12 | http.cmo 13 | 14 | all: websocketml.cma websocketml.cmxa 15 | 16 | websocketml.cma: $(OBJ) websocketml.cmi 17 | ocamlc -a -o $@ $(OBJ) websocketml.ml 18 | 19 | websocketml.cmxa: $(OBJ:.cmo=.cmx) websocketml.cmi 20 | ocamlopt -a -o $@ $(OBJ:.cmo=.cmx) websocketml.ml 21 | 22 | clean: 23 | @rm -f $(call find_rec,*.annot) $(call find_rec,*.cm[iox]) 24 | @rm -f .depend 25 | 26 | cleanall realclean mrproper: clean 27 | rm -f websocketml.cma 28 | 29 | .depend: 30 | @$(OCAMLDEP) $(INCLUDES) $(call find_rec,*.ml) $(call find_rec,*.mli) \ 31 | > .depend 32 | 33 | -include .depend 34 | -------------------------------------------------------------------------------- /src/base64.ml: -------------------------------------------------------------------------------- 1 | (* BASE64 encoding and decoding defined in 2 | RFC4648 [https://tools.ietf.org/html/rfc4648] *) 3 | 4 | exception Base64Error of string 5 | 6 | (* 64 characters + padding value (=) *) 7 | let alphabet = 8 | "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=" 9 | 10 | let get_letter i = 11 | if i > 64 then 12 | raise (Base64Error ("No letter number " ^ 13 | (string_of_int i) ^ " in base64 alphabet")); 14 | String.get alphabet i 15 | 16 | let encode s = 17 | let get_at i = int_of_char (String.get s i) in 18 | 19 | let encode_3 i1 i2 i3 = 20 | let c1 = i1 lsr 2 in 21 | let c2 = ((i1 land 0b00000011) lsl 4) lor (i2 lsr 4) in 22 | let c3 = ((i2 land 0b00001111) lsl 2) lor (i3 lsr 6) in 23 | let c4 = i3 land 0b00111111 in 24 | c1, c2, c3, c4 25 | in 26 | 27 | let encode_2 i1 i2 = 28 | let c1, c2, c3, _ = encode_3 i1 i2 0 in 29 | c1, c2, c3, 64 30 | in 31 | 32 | let encode_1 i1 = 33 | let c1, c2, _, _ = encode_2 i1 0 in 34 | c1, c2, 64, 64 35 | in 36 | 37 | let s_length = String.length s in 38 | 39 | let rec encode_step acc start_read start_write = 40 | if start_read = s_length then 41 | Bytes.to_string acc 42 | else 43 | let (c1, c2, c3, c4), new_start_read = 44 | if s_length - start_read >= 3 then 45 | encode_3 (get_at start_read) (get_at (start_read+1)) 46 | (get_at (start_read+2)), 47 | start_read + 3 48 | else if s_length - start_read = 2 then 49 | encode_2 (get_at start_read) (get_at (start_read+1)), 50 | start_read + 2 51 | else if s_length - start_read = 1 then 52 | encode_1 (get_at start_read), 53 | start_read + 1 54 | else assert false 55 | in 56 | 57 | Bytes.set acc (start_write) (get_letter c1); 58 | Bytes.set acc (start_write + 1) (get_letter c2); 59 | Bytes.set acc (start_write + 2) (get_letter c3); 60 | Bytes.set acc (start_write + 3) (get_letter c4); 61 | 62 | encode_step acc new_start_read (start_write + 4) 63 | in 64 | 65 | let encoded_size = truncate (ceil ((float s_length) /. 3.)) * 4 in 66 | encode_step (Bytes.create encoded_size) 0 0 67 | 68 | let decode s = 69 | let get_at i = String.index alphabet (String.get s i) in 70 | 71 | let decode_4 c1 c2 c3 c4 = 72 | let i1 = (c1 lsl 2) lor (c2 lsr 4) in 73 | let i2 = ((c2 land 0b001111) lsl 4) lor (c3 lsr 2) in 74 | let i3 = ((c3 land 0b000011) lsl 6) lor c4 in 75 | i1, i2, i3 76 | in 77 | 78 | let decode_3 c1 c2 c3 = 79 | let i1, i2, _ = decode_4 c1 c2 c3 0 in 80 | i1, i2, -1 81 | in 82 | 83 | let decode_2 c1 c2 = 84 | let i1, _, _ = decode_3 c1 c2 0 in 85 | i1, -1, -1 86 | in 87 | 88 | let s_length = String.length s in 89 | 90 | if s_length mod 4 <> 0 then 91 | raise (Base64Error ("decode: unvalid string of size " ^ 92 | (string_of_int s_length) ^ 93 | ", the size of a base64 encoded string " ^ 94 | "should be a multiple of 4")); 95 | 96 | let rec decode_step acc start_read start_write = 97 | if start_read = s_length then 98 | Bytes.to_string acc 99 | else 100 | let i1, i2, i3 = 101 | if String.get s (start_read + 3) = '=' then 102 | if String.get s (start_read + 2) = '=' then 103 | decode_2 (get_at start_read) (get_at (start_read + 1)) 104 | else 105 | decode_3 (get_at start_read) (get_at (start_read + 1)) 106 | (get_at (start_read + 2)) 107 | else 108 | decode_4 (get_at start_read) (get_at (start_read + 1)) 109 | (get_at (start_read + 2)) (get_at (start_read + 3)) 110 | in 111 | 112 | Bytes.set acc (start_write) (char_of_int i1); 113 | if i2 <> -1 then Bytes.set acc (start_write + 1) (char_of_int i2); 114 | if i3 <> -1 then Bytes.set acc (start_write + 2) (char_of_int i3); 115 | 116 | 117 | decode_step acc (start_read + 4) (start_write + 3) 118 | in 119 | 120 | let decoded_size = s_length * 3 / 4 in 121 | let decoded_size = 122 | if s_length > 0 then 123 | let decoded_size = 124 | if String.get s (s_length - 1) = '=' 125 | then decoded_size - 1 126 | else decoded_size 127 | in 128 | let decoded_size = 129 | if String.get s (s_length - 2) = '=' 130 | then decoded_size - 1 131 | else decoded_size 132 | in 133 | decoded_size 134 | else decoded_size 135 | in 136 | 137 | decode_step (Bytes.create decoded_size) 0 0 138 | -------------------------------------------------------------------------------- /src/http.ml: -------------------------------------------------------------------------------- 1 | (* This file implements a subset of HTTP/1.1 [RFC2616] 2 | Its only purpose is to do a websocket handshake, it cannot be used as 3 | regular HTTP server *) 4 | 5 | exception HTTPError of string 6 | 7 | let print_address ff sockaddr = 8 | let addr = 9 | match sockaddr with 10 | | Unix.ADDR_UNIX s -> s 11 | | Unix.ADDR_INET (inet, port) -> 12 | (Unix.string_of_inet_addr inet) ^ ":" ^ (string_of_int port) 13 | in 14 | Printf.fprintf ff "%s" addr 15 | 16 | (* *) 17 | 18 | module FieldMap = Map.Make(String) 19 | 20 | let print_fields print_values ff fields = 21 | let print_field ff (field, values) = 22 | Printf.fprintf ff "%s : %a" field print_values values 23 | in 24 | FieldMap.iter 25 | (fun field values -> Printf.fprintf ff "%a\n" print_field (field, values)) 26 | fields 27 | 28 | (* *) 29 | 30 | let ws_uuid = "258EAFA5-E914-47DA-95CA-C5AB0DC85B11" 31 | 32 | let build_server_key client_key = 33 | Logger.debug (fun m -> m "Got client key \"%s\"" client_key); 34 | let key = client_key ^ ws_uuid in 35 | Logger.debug (fun m -> m "Built key \"%s\"" key); 36 | let sha_hashed = Sha1.hash key in 37 | let hex_string = 38 | let inp = Bytes.of_string sha_hashed in 39 | let res = ref "" in 40 | for i = 0 to Bytes.length inp - 1 do 41 | res := !res ^ (Printf.sprintf "%02x" (int_of_char (Bytes.get inp i))) 42 | done; 43 | !res 44 | in 45 | Logger.debug (fun m -> m "SHA1 hashed to 0x%s = \"%s\"" hex_string sha_hashed); 46 | let base64_encoded = Base64.encode sha_hashed in 47 | Logger.debug (fun m -> m "Base64 encoded to \"%s\"" base64_encoded); 48 | base64_encoded 49 | 50 | (* *) 51 | 52 | let accepted_fields = 53 | [| (* as defined in the RFC, with no extension *) 54 | (* general-header, page 35 *) 55 | "Cache-Control"; "Connection"; "Date"; "Pragma"; "Trailer"; 56 | "Transfer-Encoding"; "Upgrade"; "Via"; "Warning"; 57 | (* request-header, page 38-39 *) 58 | "Accept"; "Accept-Charset"; "Accept-Encoding"; "Accept-Language"; 59 | "Authorization"; "Expect"; "From"; "Host"; "If-Match"; 60 | "If-Modified-Since"; "If-None-Match"; "If-Range"; "If-Unmodified-Since"; 61 | "Max-Forwards"; "Proxy-Authorization"; "Range"; "Referer"; "TE"; 62 | "User-Agent"; 63 | (* entity-header, page 42 *) 64 | "Allow"; "Content-Encoding"; "Content-Language"; "Content-Length"; 65 | "Content-Location"; "Content-MD5"; "Content-Range"; "Content-Type"; 66 | "Expires"; "Last-Modified"; 67 | (* extension-header *) 68 | "Origin"; "Cookie"; 69 | "Sec-WebSocket-Key"; "Sec-WebSocket-Version"; "Sec-WebSocket-Protocol"; 70 | "Sec-WebSocket-Extensions"; 71 | |] 72 | 73 | let add_field field_map field value = 74 | if not (Array.mem field accepted_fields) then 75 | Logger.warn (fun m -> m "Unknown field type %s (ignored)" field); 76 | FieldMap.add field value field_map 77 | 78 | (* *) 79 | 80 | type method_ty = 81 | (* as defined page 36*) 82 | OPTIONS | GET | HEAD | POST | PUT | DELETE | TRACE | CONNECT 83 | (* | extension-method no extension implemented yet *) 84 | 85 | let method_ty_of_string s = 86 | let s = String.uppercase_ascii s in 87 | if s = "OPTIONS" then OPTIONS 88 | else if s = "GET" then GET 89 | else if s = "HEAD" then HEAD 90 | else if s = "POST" then POST 91 | else if s = "PUT" then PUT 92 | else if s = "DELETE" then DELETE 93 | else if s = "TRACE" then TRACE 94 | else if s = "CONNECT" then CONNECT 95 | else raise (HTTPError ("Method " ^ s ^ " is not a valid HTTP/1.1 method")) 96 | 97 | let string_of_method_ty = function 98 | OPTIONS -> "OPTIONS" | GET -> "GET" | HEAD -> "HEAD" 99 | | POST -> "POST" | PUT -> "PUT" | DELETE -> "DELETE" 100 | | TRACE -> "TRACE" | CONNECT -> "CONNECT" 101 | 102 | let print_method_ty ff typ = 103 | Printf.fprintf ff "%s" (string_of_method_ty typ) 104 | 105 | (* *) 106 | 107 | type request = { 108 | typ : method_ty; 109 | uri : string; 110 | fields : string list FieldMap.t; 111 | content : string option 112 | } 113 | 114 | let typ req = req.typ 115 | let uri req = req.uri 116 | let fields req = req.fields 117 | let content req = req.content 118 | 119 | let print_request ff req = 120 | let print_values ff values = 121 | Printf.fprintf ff "%s" (String.concat ", " values) 122 | in 123 | let print_content ff = function 124 | | None -> () 125 | | Some s -> Printf.fprintf ff "%s" s 126 | in 127 | Printf.fprintf ff "%a %s HTTP/1.1\n%a\n\n%a" 128 | print_method_ty (typ req) (uri req) (print_fields print_values) (fields req) 129 | print_content (content req) 130 | 131 | (* *) 132 | 133 | (* server type, it corresponds to the root location *) 134 | type t = { 135 | addr : Unix.sockaddr; 136 | sock : Unix.file_descr 137 | } 138 | let addr serv = serv.addr 139 | let sock serv = serv.sock 140 | 141 | let to_string t = Utils.string_of_sockaddr t.addr 142 | let print_t ff t = Printf.fprintf ff "%s" (to_string t) 143 | 144 | (* *) 145 | 146 | let parse_request req = 147 | (* split header and content *) 148 | let aux = Str.bounded_split_delim (Str.regexp "\(\r\n\r\n\)\|\(\n\n\)") req 2 in 149 | 150 | let header = List.hd aux in 151 | let content = List.nth_opt aux 1 in 152 | 153 | (* split request line and field lines *) 154 | let header_lines = Str.split (Str.regexp "\(\r\n\)\|\(\n\)") header in 155 | let request_line = List.hd header_lines in 156 | let field_lines = List.tl header_lines in 157 | 158 | (* parse request line *) 159 | let aux = Str.split (Str.regexp "[ \t]") request_line in 160 | let method_ty = String.trim (List.hd aux) in 161 | let request_uri = String.trim (List.hd (List.tl aux)) in 162 | let protocol = String.trim (List.hd (List.tl (List.tl aux))) in 163 | 164 | (* check if protocol is HTTP/1.1 *) 165 | let protocol = String.uppercase_ascii protocol in 166 | if protocol <> "HTTP/1.1" then 167 | raise (HTTPError ("Unknown protocol " ^ protocol ^ ". Supported protocols are : HTTP/1.1")); 168 | 169 | (* check and get method type *) 170 | let method_ty = method_ty_of_string method_ty in 171 | 172 | (* parse field lines *) 173 | let field_map = List.fold_left (fun field_map field_line -> 174 | if String.trim field_line = "" then field_map 175 | else 176 | let aux = Str.bounded_split (Str.regexp ":") field_line 2 in 177 | if List.length aux <> 2 then 178 | raise (HTTPError ("Not a valid field: " ^ field_line)); 179 | let field = String.trim (List.hd aux) in 180 | let values = List.hd (List.tl aux) in 181 | let values = String.split_on_char ',' values in 182 | let values = List.map String.trim values in 183 | add_field field_map field values 184 | ) FieldMap.empty field_lines 185 | in 186 | 187 | { typ = method_ty; uri = request_uri; 188 | fields = field_map; content = content } 189 | 190 | let create inet_addr = 191 | let tcp_protocol = 6 in 192 | Logger.info (fun m -> m "Starting server on %a" print_address inet_addr); 193 | let sock = Unix.socket PF_INET SOCK_STREAM tcp_protocol in 194 | Unix.setsockopt sock SO_REUSEADDR true; 195 | Unix.bind sock inet_addr; 196 | { addr = inet_addr; sock = sock } 197 | 198 | let close serv = 199 | Unix.shutdown (sock serv) SHUTDOWN_ALL; 200 | Unix.close (sock serv); 201 | Logger.info (fun m -> m "Server closed") 202 | 203 | let listen serv = 204 | Unix.listen (sock serv) 1; 205 | Logger.info (fun m -> m "%s" "Listening to new connections") 206 | 207 | let accept serv = 208 | let client_sock, client_addr = Unix.accept (sock serv) in 209 | Logger.info (fun m -> m "Got a connection from %a" print_address client_addr); 210 | client_sock, client_addr 211 | 212 | let listen_and_accept serv = 213 | listen serv; accept serv 214 | 215 | let send_response sock status fields = 216 | let message = "HTTP/1.1 " ^ status ^ "\n" ^ 217 | (String.concat "\n" 218 | (List.map (fun (field,value) -> field ^ ":" ^ value) 219 | fields)) ^ 220 | "\n\n" 221 | in 222 | let code = Unix.send sock (Bytes.of_string message) 0 (String.length message) [] in 223 | Logger.info (fun m -> m "Sent:\n%s" message); 224 | code 225 | 226 | 227 | let check_ws_opening_request req = 228 | (* check requirements of the opening request, RFC page 21 *) 229 | 230 | let check_key key = 231 | if not (FieldMap.mem key req.fields) then 232 | raise (HTTPError ("The opening HTTP request MUST contain a \"" ^ key ^ 233 | "\" field")) 234 | in 235 | let check_val key value = 236 | check_key key; 237 | let field = FieldMap.find key req.fields in 238 | if List.length field = 1 then 239 | if String.lowercase_ascii (List.hd field) = "websocket" then () 240 | else 241 | raise (HTTPError ("The opening HTTP request MUST contain an \"" ^ key ^ 242 | "\" field with value \"" ^ value ^ "\"")) 243 | in 244 | let include_val key value = 245 | check_key key; 246 | let lowercase_value = String.lowercase_ascii value in 247 | let values = FieldMap.find key req.fields in 248 | let lowercase_values = List.map String.lowercase_ascii values in 249 | if not (List.mem lowercase_value lowercase_values) then 250 | raise (HTTPError ("The opening HTTP request MUST contain a \"" ^ key ^ 251 | "\" field including the value \"" ^ value ^ "\"")) 252 | in 253 | 254 | 255 | (* 1 - Request has to be a GET request*) 256 | if req.typ <> GET then 257 | raise (HTTPError ("The opening HTTP request MUST be a GET, not a " ^ 258 | (string_of_method_ty req.typ))); 259 | 260 | (* 2 - A |Host| header field *) 261 | check_key "Host"; 262 | 263 | (* 3 - A |Upgrade| header field containing the value "websocket" *) 264 | check_val "Upgrade" "websocket"; 265 | 266 | (* 4 - A |Connection| header field that includes the token "Upgrade" *) 267 | include_val "Connection" "Upgrade"; 268 | 269 | (* 5 - A |Sec-WebSocket-Key| header field with base64-encoded value that, 270 | when decoded, is 16 bytes in length *) 271 | let encoded_ws_key = FieldMap.find "Sec-WebSocket-Key" req.fields in 272 | if List.length encoded_ws_key <> 1 then 273 | raise (HTTPError ("The field Sec-WebSocket-Key MUST have one (and only one) value")); 274 | 275 | let decoded_ws_key = Base64.decode (List.hd encoded_ws_key) in 276 | if String.length decoded_ws_key <> 16 then 277 | raise (HTTPError ("The decoded WebSocket key has length " ^ 278 | (string_of_int (String.length decoded_ws_key)) ^ 279 | " while it was expected to have length 16")); 280 | 281 | (* 6 - A |Sec-WebSocket-Version| header field *) 282 | check_key "Sec-WebSocket-Version"; 283 | 284 | (* 7 - Optionnally, an |Origin| field *) 285 | (* 8 - Optionnally, a |Sec-WebSocket-Protocol| field *) 286 | (* 9 - Optionnally, a |Sec-WebSocket-Extensions| field *) 287 | (* 10 - Optionnally, other fields *) 288 | () 289 | 290 | let do_ws_handshake sock = 291 | let rcv_buffer = Bytes.create 1024 in 292 | ignore (Unix.recv sock rcv_buffer 0 1024 []); 293 | let req = Bytes.to_string rcv_buffer in 294 | (* If the message is more than 1024 bytes long, this won't work *) 295 | let req = String.sub req 0 (String.index req '\000') in 296 | Logger.info (fun m -> m "Received message:\n%s\n" req); 297 | let req = parse_request req in 298 | 299 | (* NOTE : req.uri is a /ressource name/ 300 | 301 | cited from page 14 of RFC6455 : 302 | 303 | The ressource name can be constructed by concatenating the following : 304 | - "/" if the path component is empty 305 | - the path component 306 | - "?" if the query component is non-empty 307 | - the query component 308 | 309 | END OF CITATION 310 | 311 | ie the uri looks like ("/" | PATH)[?(QUERY)*] 312 | *) 313 | 314 | check_ws_opening_request req; 315 | 316 | (* build response to opening request, page 22 *) 317 | 318 | (* Note : Not used *) 319 | (* get origin key if present *) 320 | (* let origin = 321 | match FieldMap.find_opt "Origin" req.fields with 322 | | None -> None 323 | | Some origin -> 324 | if List.length origin <> 1 then 325 | raise (WSError ("The optional field Origin MUST have one and only one value")); 326 | let origin = String.lowercase_ascii (List.hd origin) in 327 | Some origin 328 | in *) 329 | 330 | (* get ws key *) 331 | (* size of list has been checked before *) 332 | let encoded_ws_key = List.hd (FieldMap.find "Sec-WebSocket-Key" req.fields) in 333 | 334 | (* get version *) 335 | let version = FieldMap.find "Sec-WebSocket-Version" req.fields in 336 | if List.length version <> 1 then 337 | raise (HTTPError ("The field Sec-WebSocket-Version MUST have one and only one value")); 338 | if (List.hd version) <> "13" then begin 339 | ignore (send_response sock "426 Upgrade Required" [ 340 | "Sec-WebSocket-Version", "13" ]); 341 | raise (HTTPError ("Unsupported WebSocket version" ^ (List.hd version))) 342 | end; 343 | 344 | (* subprotocol to use : none implemented yet *) 345 | (* extensions to use : none implemented yet *) 346 | 347 | ignore (send_response sock "101 Switching Protocols" [ 348 | "Upgrade", "websocket"; 349 | "Connection", "Upgrade"; 350 | "Sec-WebSocket-Accept", build_server_key encoded_ws_key; 351 | ]) 352 | -------------------------------------------------------------------------------- /src/logger.ml: -------------------------------------------------------------------------------- 1 | module EscCodes = struct 2 | let none = "\027[0;0m" 3 | 4 | let bold = "\027[0;1m" 5 | let faint = "\027[0;2m" 6 | 7 | let italic = "\027[0;3m" 8 | let underline = "\027[0;4m" 9 | let slow_blink = "\027[0;5m" 10 | let rapid_blink = "\027[0;6m" 11 | 12 | let black = "\027[0;30m" 13 | let dark_gray = "\027[1;30m" 14 | let red = "\027[0;31m" 15 | let light_red = "\027[1;31m" 16 | let green = "\027[0;32m" 17 | let light_green = "\027[1;32m" 18 | let orange = "\027[0;33m" 19 | let yellow = "\027[1;33m" 20 | let blue = "\027[0;34m" 21 | let light_blue = "\027[1;34m" 22 | let purple = "\027[0;35m" 23 | let light_purple = "\027[1;35m" 24 | let cyan = "\027[0;36m" 25 | let light_cyan = "\027[1;36m" 26 | let light_gray = "\027[0;37m" 27 | let white = "\027[1;37m" 28 | end 29 | 30 | type verbose = ERROR | WARN | INFO | DEBUG 31 | 32 | let level_of_verbose = function 33 | | ERROR -> 0 | WARN -> 1 | INFO -> 2 | DEBUG -> 3 34 | 35 | let verbose = ref INFO 36 | let set_verbose v = verbose := v 37 | 38 | let print ff color prefix f = 39 | Printf.fprintf ff "%s%-7s " color ("[" ^ prefix ^ "]"); 40 | f (Printf.fprintf ff); 41 | Printf.fprintf ff "%s\n" EscCodes.none; 42 | flush stdout 43 | 44 | let print_level level ff color prefix f = 45 | if level_of_verbose level <= level_of_verbose !verbose then print ff color prefix f 46 | 47 | let error f = print_level ERROR stdout EscCodes.red "ERROR" f 48 | let warn f = print_level WARN stdout EscCodes.orange "WARN" f 49 | 50 | let info f = print_level INFO stdout EscCodes.light_blue "INFO" f 51 | let debug f = print_level DEBUG stdout EscCodes.yellow "DEBUG" f 52 | 53 | (* Test *) 54 | (* let _ = 55 | error (fun m -> m "%s" "ERROR !!"); 56 | info (fun m -> m "%s" "info"); 57 | warn (fun m -> m "%s" "Warn"); 58 | debug (fun m -> m "%s" "debug"); 59 | () *) 60 | -------------------------------------------------------------------------------- /src/sha1.ml: -------------------------------------------------------------------------------- 1 | (* SHA1 encoding defined in RFC3174 *) 2 | 3 | exception Sha1Error of string 4 | 5 | open Bytes 6 | 7 | let show_byte ff b = 8 | Printf.fprintf ff "%s" (Utils.hex_string_of_bytes b) 9 | 10 | let show_intarray ff a = 11 | Printf.fprintf ff "%s" "\t\t"; 12 | Array.iteri (fun i v -> 13 | Printf.fprintf ff "%08x%s" v (if (i + 1) mod 10 = 0 then "\n\t\t" else " ") 14 | ) a 15 | 16 | let show_int32array ff a = 17 | Printf.fprintf ff "%s" "\t\t"; 18 | Array.iteri (fun i v -> 19 | let v = Int32.to_int v in 20 | Printf.fprintf ff "%08x%s" v (if (i + 1) mod 10 = 0 then "\n\t\t" else " ") 21 | ) a 22 | 23 | let bytes_of_h (h0, h1, h2, h3, h4) = 24 | let res = Bytes.create 20 in 25 | set_int32_be res 0 h0; 26 | set_int32_be res 4 h1; 27 | set_int32_be res 8 h2; 28 | set_int32_be res 12 h3; 29 | set_int32_be res 16 h4; 30 | res 31 | 32 | let read_int32 b i = get_int32_be b i 33 | 34 | let ( +++ ) a b : int32 = Int32.add a b 35 | let circular_left_shift n x : int32 = 36 | Int32.logor (Int32.shift_left x n) 37 | (Int32.shift_right_logical x (32-n)) 38 | 39 | let f t b c d : int32 = 40 | if t >= 0 && t <= 19 then Int32.logor (Int32.logand b c) (Int32.logand (Int32.lognot b) d) 41 | else if t >= 20 && t <= 39 then Int32.logxor b (Int32.logxor c d) 42 | else if t >= 40 && t <= 59 then Int32.logor (Int32.logand b c) (Int32.logor (Int32.logand b d) (Int32.logand c d)) 43 | else if t >= 60 && t <= 79 then Int32.logxor b (Int32.logxor c d) 44 | else raise (Sha1Error ("f(t,B,C,D) : Unvalid argument t = " ^ (string_of_int t))) 45 | 46 | let k t : int32 = 47 | if t >= 0 && t <= 19 then Int32.of_int 0x5A827999 48 | else if t >= 20 && t <= 39 then Int32.of_int 0x6ED9EBA1 49 | else if t >= 40 && t <= 59 then Int32.of_int 0x8F1BBCDC 50 | else if t >= 60 && t <= 79 then Int32.of_int 0xCA62C1D6 51 | else raise (Sha1Error ("k(t) : Unvalid argument t = " ^ (string_of_int t))) 52 | 53 | let pad s = 54 | let original_length = Bytes.length s in 55 | let n_blocks = truncate (ceil ((float original_length) /. 64.)) in 56 | let n_blocks = 57 | (* we need enough space to add a bit of 1 (it will be the byte 0x80 since 58 | the message is a string so its length in bits is a multiple of 8) 59 | and two bytes for the length of the string *) 60 | if original_length mod 64 > 0 && original_length mod 64 < 52 61 | then n_blocks 62 | else n_blocks + 1 63 | in 64 | 65 | let res = Bytes.make (n_blocks * 64) (char_of_int 0) in 66 | 67 | (* start by copying the message *) 68 | Bytes.blit s 0 res 0 original_length; 69 | 70 | (* write 1 after the message (here we write the byte 0b10000000) *) 71 | Bytes.set res original_length (char_of_int 0x80); 72 | 73 | (* write the original length of the message as a 2 bytes integer at the end *) 74 | (* NOTE : this is taken from the JS code found in 75 | www.movable-type.co.uk/scripts/sha1.html, I do not yet understand 76 | why the length is shifted 3 times to the left *) 77 | let length_1 = (original_length lsl 3) lsr 32 in 78 | let length_2 = (original_length lsl 3) land 0xFFFFFFFF in 79 | set_int32_be res (n_blocks * 64 - 8) (Int32.of_int length_1); 80 | set_int32_be res (n_blocks * 64 - 4) (Int32.of_int length_2); 81 | 82 | res 83 | 84 | let digest_block (h0, h1, h2, h3, h4) block = 85 | (* block is a 512 bits block *) 86 | (* let w = Bytes.create (80 * 4) in *) 87 | let w = Array.make 80 Int32.zero in 88 | 89 | (* 16 first loops : Divide block into 16 words W(0), W(1), ... , W(15) *) 90 | for i = 0 to 15 do 91 | w.(i) <- read_int32 block (4 * i); 92 | done; 93 | 94 | for i = 16 to 79 do 95 | let aux = Int32.logxor (Int32.logxor w.(i-3) w.(i-8)) 96 | (Int32.logxor w.(i-14) w.(i-16)) in 97 | w.(i) <- (circular_left_shift 1 aux) 98 | done; 99 | 100 | let a = ref h0 and b = ref h1 and c = ref h2 and d = ref h3 and e = ref h4 in 101 | 102 | for i = 0 to 79 do 103 | let tmp = (circular_left_shift 5 !a) +++ (f i !b !c !d) +++ !e +++ 104 | (w.(i)) +++ (k i) in 105 | e := !d; d := !c; 106 | c := circular_left_shift 30 !b; 107 | b := !a; a := tmp 108 | done; 109 | 110 | let new_h = h0 +++ !a, h1 +++ !b, h2 +++ !c, h3 +++ !d, h4 +++ !e in 111 | new_h 112 | 113 | let hash s = 114 | let s = pad (Bytes.of_string s) in 115 | let s_length = Bytes.length s in 116 | let rec step h start = 117 | if start >= s_length then 118 | Bytes.to_string (bytes_of_h h) 119 | else 120 | let new_h = digest_block h (Bytes.sub s start 64) in 121 | step new_h (start + 64) 122 | in step (Int32.of_int 0x67452301, 123 | Int32.of_int 0xEFCDAB89, 124 | Int32.of_int 0x98BADCFE, 125 | Int32.of_int 0x10325476, 126 | Int32.of_int 0xC3D2E1F0) 127 | 0 128 | -------------------------------------------------------------------------------- /src/utils.ml: -------------------------------------------------------------------------------- 1 | let hex_string_of_bytes b = 2 | let res = ref ["\t\t"] in 3 | for i = 0 to Bytes.length b - 1 do 4 | res := (Printf.sprintf "0x%02x%s" 5 | (int_of_char (Bytes.get b i)) 6 | (if i mod 20 = 19 then "\n\t\t" else " ")) 7 | :: !res 8 | done; 9 | String.concat "" (List.rev !res) 10 | 11 | let string_of_sockaddr = function 12 | | Unix.ADDR_UNIX s -> s 13 | | Unix.ADDR_INET (a,p) -> (Unix.string_of_inet_addr a) ^ ":" ^ (string_of_int p) 14 | 15 | (* b is a uint8 *) 16 | let split_first_bit b = 17 | let first_bit = b lsr 7 in 18 | (first_bit = 1), b land 0b01111111 19 | 20 | (* decode data in-place *) 21 | let unmask_data mask data = 22 | let char_xor (b1 : char) (b2 : char) = 23 | char_of_int ((int_of_char b1) lxor (int_of_char b2)) 24 | in 25 | for i = 0 to Bytes.length data - 1 do 26 | Bytes.set data i (char_xor (Bytes.get data i) (Bytes.get mask (i mod 4))); 27 | done; 28 | data 29 | 30 | let apply_opt f = function 31 | | None -> None 32 | | Some x -> Some (f x) 33 | -------------------------------------------------------------------------------- /src/websocketml.ml: -------------------------------------------------------------------------------- 1 | module Logger = Logger 2 | module Http = Http 3 | 4 | include Ws 5 | -------------------------------------------------------------------------------- /src/websocketml.mli: -------------------------------------------------------------------------------- 1 | (** This library implements {{:https://tools.ietf.org/html/rfc6455}RFC6455}. 2 | There are currently no supported extensions. 3 | *) 4 | 5 | (** {1 WS} *) 6 | 7 | exception WSError of string 8 | 9 | type t 10 | 11 | type msg_type = BinaryMsg | TextMsg 12 | type msg = { msg_typ : msg_type; msg_data : bytes } 13 | 14 | (** All these op codes are defined in the RFC *) 15 | type opcode = 16 | | ContinuationFrame | TextFrame | BinaryFrame | Close | Ping | Pong 17 | | ControlFrame of int | NonControlFrame of int 18 | 19 | (** All these exit codes are defined in the RFC *) 20 | type exit_code = 21 | | NormalClosure (** 1000 *) 22 | | GoingAway (** 1001 *) 23 | | ProtocolError (** 1002 *) 24 | | UnkownDatatype (** 1003 *) 25 | | NoStatusCode (** 1005 *) 26 | | AbnormalClosure (** 1006 *) 27 | | InconsistentData (** 1007 *) 28 | | PolicyViolation (** 1008 *) 29 | | MsgTooBig (** 1009 *) 30 | | RequiredExtension (** 1010 *) 31 | | UnexpectedCondition (** 1011 *) 32 | | TLSFailure (** 1015 *) 33 | | ReservedCode of int (** ranges : 34 | 0 - 999 : not used 35 | 1000 - 2999 : reserved for websocket protocol 36 | 3000 - 3999 : reserved for public libraries *) 37 | | CustomCode of int (** range 4000 - 4999 : private use *) 38 | 39 | (** Create a new connexion. 40 | 41 | WARNING: this method assumes that the socket is already open and that 42 | the WebSocket handshake has already been performed. Refer to 43 | {!Http.create}, {!Http.listen_and_accept} and 44 | {!Http.do_ws_handshake} methods of module {!Http}. 45 | *) 46 | val create : Unix.file_descr * Unix.sockaddr -> t 47 | 48 | (** Get the unix socket *) 49 | val get_sock : t -> Unix.file_descr 50 | 51 | (** Get remote address *) 52 | val get_addr : t -> Unix.sockaddr 53 | 54 | (** {2 Read} *) 55 | 56 | (** Block until a complete message is received. This method may read several 57 | frames in a single call until it reaches the final frame of the message. 58 | 59 | If the received frame is a Close frame, it closes the connection and returns 60 | None. 61 | 62 | If the received frame is a Ping, it answers with an appropriate Pong and 63 | returns None. 64 | 65 | If the received frame is a Pong, it outputs a debug message and returns 66 | None. 67 | 68 | Raise {!WSError} if the socket is closed or if the received message is 69 | ill-formed. 70 | *) 71 | val receive_message : t -> msg option 72 | 73 | (** {2 Write} *) 74 | (** These method may raise {!WSError} if the socket is closed *) 75 | 76 | val send_msg : t -> opcode -> bytes -> int 77 | val send_ping : t -> bytes -> int 78 | val send_text : t -> string -> int 79 | val send_binary : t -> bytes -> int 80 | val close : t -> exit_code -> int 81 | val close_with_message : t -> exit_code -> string -> int 82 | 83 | (** {2 Helpers} *) 84 | 85 | (** Return true if the socket cannot be read from *) 86 | val closed_in : t -> bool 87 | 88 | (** Return true if the socket cannot be written to *) 89 | val closed_out : t -> bool 90 | 91 | (** Return true if the socket cannot be read from or written to *) 92 | val closed : t -> bool 93 | 94 | val to_string : t -> string 95 | val print_t : out_channel -> t -> unit 96 | 97 | (** {1 HTTP} *) 98 | 99 | (** Implement a subset of HTTP/1.1 {{:https://tools.ietf.org/html/rfc2616}RFC2616}. 100 | Its only purpose is to do a websocket handshake, it cannot be used as 101 | regular HTTP server. One could use any other mean to retrieve an open 102 | socket and client address to use as inputs of {!Websocketml.create}. 103 | *) 104 | module Http : 105 | sig 106 | exception HTTPError of string 107 | 108 | type t 109 | 110 | (** Create a TCP socket and bind it to given address *) 111 | val create : Unix.sockaddr -> t 112 | 113 | (** Set up the socket for receiving connection requests 114 | (with a pending list of size 1) *) 115 | val listen : t -> unit 116 | 117 | (** Block until a connection is received and return the socket and address 118 | of the connecting client *) 119 | val accept : t -> Unix.file_descr * Unix.sockaddr 120 | 121 | (** Call listen then accept *) 122 | val listen_and_accept : t -> Unix.file_descr * Unix.sockaddr 123 | 124 | (** Read a WebSocket opening request on the given socket and answer with 125 | an appropriate message to complete the handshake defined 126 | by {{:https://tools.ietf.org/html/rfc6455}RFC6455}. 127 | 128 | Raise {!HTTPError} if the received request is not a valid HTTP request or 129 | if it is not a valid WebSocket opening request. 130 | *) 131 | val do_ws_handshake : Unix.file_descr -> unit 132 | 133 | (** Close the server's TCP socket *) 134 | val close : t -> unit 135 | 136 | val to_string : t -> string 137 | val print_t : out_channel -> t -> unit 138 | end 139 | 140 | (** {1 Logger} *) 141 | 142 | (** usage example: {v Logger.info (fun f -> f "[%s] %d" some_string some_int) v} *) 143 | module Logger : 144 | sig 145 | type verbose = ERROR | WARN | INFO | DEBUG 146 | val set_verbose : verbose -> unit 147 | 148 | val error : ((('a, out_channel, unit) format -> 'a) -> 'b) -> unit 149 | val warn : ((('a, out_channel, unit) format -> 'a) -> 'b) -> unit 150 | val info : ((('a, out_channel, unit) format -> 'a) -> 'b) -> unit 151 | val debug : ((('a, out_channel, unit) format -> 'a) -> 'b) -> unit 152 | end 153 | -------------------------------------------------------------------------------- /src/ws.ml: -------------------------------------------------------------------------------- 1 | (* RFC6455 *) 2 | 3 | open Bytes 4 | open Utils 5 | 6 | exception WSError of string 7 | exception NotImplemented of string 8 | 9 | (* ============================================ *) 10 | (* OPCODE *) 11 | (* ============================================ *) 12 | 13 | type opcode = 14 | | ContinuationFrame | TextFrame | BinaryFrame | Close | Ping | Pong 15 | | ControlFrame of int | NonControlFrame of int 16 | 17 | let int_of_opcode = function 18 | | ContinuationFrame -> 0 | TextFrame -> 1 | BinaryFrame -> 2 19 | | Close -> 8 | Ping -> 9 | Pong -> 10 20 | | ControlFrame i | NonControlFrame i -> i 21 | 22 | let opcode_of_int i = 23 | if i = 0 then ContinuationFrame 24 | else if i = 1 then TextFrame 25 | else if i = 2 then BinaryFrame 26 | else if i = 3 then NonControlFrame 3 27 | else if i = 4 then NonControlFrame 4 28 | else if i = 5 then NonControlFrame 5 29 | else if i = 6 then NonControlFrame 6 30 | else if i = 7 then NonControlFrame 7 31 | else if i = 8 then Close 32 | else if i = 9 then Ping 33 | else if i = 10 then Pong 34 | else if i = 11 then ControlFrame 11 35 | else if i = 12 then ControlFrame 12 36 | else if i = 13 then ControlFrame 13 37 | else if i = 14 then ControlFrame 14 38 | else if i = 15 then ControlFrame 15 39 | else raise (WSError ("Unknown op code " ^ (string_of_int i))) 40 | 41 | let string_of_opcode = function 42 | | ContinuationFrame -> "ContinuationFrame" | TextFrame -> "TextFrame" 43 | | BinaryFrame -> "BinaryFrame" | Close -> "Close" 44 | | Ping -> "Ping" | Pong -> "Pong" 45 | | ControlFrame i -> "ControlFrame " ^ (string_of_int i) 46 | | NonControlFrame i -> "NonControlFrame " ^ (string_of_int i) 47 | 48 | let is_controlop = function 49 | | ContinuationFrame | TextFrame | BinaryFrame | NonControlFrame _ -> false 50 | | Close | Ping | Pong | ControlFrame _ -> true 51 | 52 | (* ============================================ *) 53 | (* STATUS CODE *) 54 | (* ============================================ *) 55 | 56 | (* cf. RFC6455 page 46 *) 57 | type exit_code = 58 | (* These are defined in the RFC *) 59 | | NormalClosure (* 1000 *) 60 | | GoingAway (* 1001 *) 61 | | ProtocolError (* 1002 *) 62 | | UnkownDatatype (* 1003 *) 63 | | NoStatusCode (* 1005 *) 64 | | AbnormalClosure (* 1006 *) 65 | | InconsistentData (* 1007 *) 66 | | PolicyViolation (* 1008 *) 67 | | MsgTooBig (* 1009 *) 68 | | RequiredExtension (* 1010 *) 69 | | UnexpectedCondition (* 1011 *) 70 | | TLSFailure (* 1015 *) 71 | | ReservedCode of int (* ranges : 72 | 0 - 999 : not used 73 | 1000 - 2999 : reserved for websocket protocol 74 | 3000 - 3999 : reserved for public libraries *) 75 | | CustomCode of int (* range 4000 - 4999 : private use *) 76 | 77 | let reserved_exit_code = function 78 | | NormalClosure | GoingAway | ProtocolError | UnkownDatatype 79 | | InconsistentData | PolicyViolation | MsgTooBig | RequiredExtension 80 | | UnexpectedCondition -> false 81 | | NoStatusCode | AbnormalClosure | TLSFailure 82 | | ReservedCode _ | CustomCode _ -> true 83 | 84 | let int_of_exit_code = function 85 | | NormalClosure -> 1000 86 | | GoingAway -> 1001 87 | | ProtocolError -> 1002 88 | | UnkownDatatype -> 1003 89 | | NoStatusCode -> 1005 90 | | AbnormalClosure -> 1006 91 | | InconsistentData -> 1007 92 | | PolicyViolation -> 1008 93 | | MsgTooBig -> 1009 94 | | RequiredExtension -> 1010 95 | | UnexpectedCondition -> 1011 96 | | TLSFailure -> 1015 97 | | ReservedCode i | CustomCode i -> i 98 | 99 | let exit_code_of_int i = 100 | if i = 1000 then NormalClosure 101 | else if i = 1001 then GoingAway 102 | else if i = 1002 then ProtocolError 103 | else if i = 1003 then UnkownDatatype 104 | else if i = 1005 then NoStatusCode 105 | else if i = 1006 then AbnormalClosure 106 | else if i = 1007 then InconsistentData 107 | else if i = 1008 then PolicyViolation 108 | else if i = 1009 then MsgTooBig 109 | else if i = 1010 then RequiredExtension 110 | else if i = 1011 then UnexpectedCondition 111 | else if i = 1015 then TLSFailure 112 | else if i >= 0 && i <= 999 || 113 | i >= 1000 && i <= 2999 || 114 | i >= 3000 && i <= 3999 then ReservedCode i 115 | else if i >= 4000 && i <= 4999 then CustomCode i 116 | else raise (WSError ("Unknown exit code " ^ string_of_int i)) 117 | 118 | (* ============================================ *) 119 | (* FRAME *) 120 | (* ============================================ *) 121 | 122 | type frame = { fin : bool; opcode : opcode; frame_data : bytes} 123 | 124 | (* ============================================ *) 125 | (* MSG *) 126 | (* ============================================ *) 127 | 128 | type msg_type = BinaryMsg | TextMsg 129 | type msg = { msg_typ : msg_type; msg_data : bytes } 130 | 131 | (* ============================================ *) 132 | (* CLIENT *) 133 | (* ============================================ *) 134 | 135 | type client = { 136 | addr : Unix.sockaddr; 137 | sock : Unix.file_descr 138 | } 139 | 140 | let string_of_client c = string_of_sockaddr c.addr 141 | 142 | (* ============================================ *) 143 | (* WEBSOCKET *) 144 | (* ============================================ *) 145 | 146 | type t = { 147 | client : client; 148 | mutable closed_out : bool; 149 | mutable closed_in : bool; 150 | } 151 | 152 | let to_string sock = string_of_client sock.client 153 | let print_t ff sock = Printf.fprintf ff "%s" (to_string sock) 154 | 155 | let warn excptn = 156 | match excptn with 157 | | WSError s 158 | | NotImplemented s -> 159 | Printf.eprintf "Warning: %s\n" s 160 | | _ -> raise excptn 161 | 162 | let create (sock, addr) = { 163 | client = { sock = sock; 164 | addr = addr; }; 165 | closed_in = false; 166 | closed_out = false; 167 | } 168 | 169 | let get_sock sock = sock.client.sock 170 | let get_addr sock = sock.client.addr 171 | let closed_out sock = sock.closed_out 172 | let closed_in sock = sock.closed_in 173 | let closed sock = sock.closed_in || sock.closed_out 174 | 175 | let recv_bytes sock rcv_buffer offset size = 176 | if closed_in sock then 177 | raise (WSError "WebSocket.recv_bytes : Connection is closed"); 178 | let code = Unix.recv (get_sock sock) rcv_buffer offset size [] in 179 | code 180 | 181 | let send_bytes sock b = 182 | if closed_out sock then 183 | raise (WSError "WebSocket.send_bytes : Connection is closed"); 184 | Unix.send (get_sock sock) b 0 (Bytes.length b) [] 185 | 186 | let build_frame op data = 187 | let data_len = Bytes.length data in 188 | 189 | (* payload_len bytes *) 190 | let payload_len_additional_length, payload_len = 191 | if data_len < 126 then begin 192 | let res = Bytes.create 1 in 193 | set_uint8 res 0 data_len; 194 | 0, res 195 | end else if data_len < 65536 then begin 196 | let res = Bytes.create 3 in 197 | set_uint8 res 0 126; 198 | set_uint16_be res 1 data_len; 199 | 2, res 200 | end else begin 201 | let res = Bytes.create 9 in 202 | set_int8 res 0 127; 203 | set_int64_be res 1 (Int64.of_int data_len); 204 | 8, res 205 | end 206 | in 207 | 208 | let length = 209 | 1 + (* FIN | RSV 1/2/3 | OPCODE byte *) 210 | 1 + (* MASK | PAYLOAD_LEN byte *) 211 | payload_len_additional_length + (* additional length *) 212 | data_len (* size of data *) 213 | in 214 | let msg = Bytes.create length in 215 | (* the server does not perform any fragmentation for now, the FIN 216 | flag is always set to 1 *) 217 | let first_byte = 128 + int_of_opcode op in 218 | set_uint8 msg 0 first_byte; 219 | (* the server does not mask its data, the MASK flag is always 0 *) 220 | Bytes.blit payload_len 0 msg 1 (1 + payload_len_additional_length); 221 | (* finally, we add the message *) 222 | Bytes.blit data 0 msg (2 + payload_len_additional_length) data_len; 223 | 224 | msg 225 | 226 | (* TODO : handle fragmentation for big messages *) 227 | let build_msg op data = build_frame op data 228 | let send_msg sock op data = 229 | let msg = build_msg op data in 230 | Logger.debug (fun m -> m "Sending %s message with content\n\t\t%s" 231 | (string_of_opcode op) 232 | (Bytes.to_string data)); 233 | send_bytes sock msg 234 | let send_ping sock data = send_msg sock Ping data 235 | let send_pong sock data = send_msg sock Pong data 236 | let send_close sock data = send_msg sock Close data 237 | let send_text sock msg = send_msg sock TextFrame (Bytes.of_string msg) 238 | let send_binary sock data = send_msg sock BinaryFrame data 239 | 240 | let close_with_message sock exit_code msg = 241 | let data = 242 | if reserved_exit_code exit_code then Bytes.empty 243 | else begin 244 | let exit_code_byte = Bytes.create 2 in 245 | set_uint16_be exit_code_byte 0 (int_of_exit_code exit_code); 246 | Bytes.cat exit_code_byte (Bytes.of_string msg) 247 | end 248 | in 249 | let code = send_close sock data in 250 | sock.closed_out <- true; 251 | code 252 | 253 | let close sock exit_code = close_with_message sock exit_code "" 254 | 255 | let do_close sock frame = 256 | (* optional exit code *) 257 | let code = 258 | if Bytes.length frame.frame_data >= 2 then 259 | get_uint16_be frame.frame_data 0 260 | else 1005 261 | in 262 | let reason = 263 | if Bytes.length frame.frame_data > 2 then 264 | Bytes.sub_string frame.frame_data 2 (Bytes.length frame.frame_data - 2) 265 | else "" 266 | in 267 | Logger.debug (fun m -> m "WebSocket connection closed with code %d and reason : %s" code reason); 268 | sock.closed_in <- true; 269 | close sock (exit_code_of_int code) 270 | 271 | let receive_frame sock = 272 | Logger.debug (fun m -> m "%s" "Waiting for frame ..."); 273 | 274 | let rcv_buffer = Bytes.create 2 in 275 | 276 | ignore (recv_bytes sock rcv_buffer 0 2); 277 | 278 | (* first byte is : FIN(1) RSV1(1) RSV2(1) RSV3(1) OPCODE(4)*) 279 | let first_byte = get_uint8 rcv_buffer 0 in 280 | 281 | let fin, opcode = split_first_bit first_byte in 282 | 283 | Logger.debug (fun m -> m "FIN : %s" (if fin then "1" else "0")); 284 | 285 | (* no extensions : RSV1/2/3 MUST be 0 *) 286 | if (opcode > 16) then 287 | warn (WSError 288 | ("No extension has been negotiated and RSV1/2/3 bits are not 0 (opcode = " ^ 289 | (string_of_int opcode) ^ ")")); 290 | 291 | let opcode = opcode_of_int opcode in 292 | 293 | Logger.debug (fun m -> m "OPCODE: %d (%s)" (int_of_opcode opcode) (string_of_opcode opcode)); 294 | 295 | (* second byte is : MASK(1) PAYLOAD_LEN(7) *) 296 | let second_byte = get_uint8 rcv_buffer 1 in 297 | let mask, payload_len = split_first_bit second_byte in 298 | 299 | Logger.debug (fun m -> m "MASK : %s" (if mask then "1" else "0")); 300 | Logger.debug (fun m -> m "PAYLOAD LEN : %d" payload_len); 301 | 302 | (* the sock MUST mask its message *) 303 | if not mask then raise (WSError "The sock frame is not masked"); 304 | 305 | (* if payload len = 126, payload length (in bytes) is the next 2 bytes, 306 | if payload len = 127, payload length (in bytes) is the next 4 bytes 307 | else payload len is the payload length (in bytes)*) 308 | let payload_len = 309 | if payload_len = 126 then begin 310 | ignore (recv_bytes sock rcv_buffer 2 2); 311 | get_uint8 rcv_buffer 0 312 | end else if payload_len = 126 then begin 313 | ignore (recv_bytes sock rcv_buffer 2 8); 314 | Int64.to_int (get_int64_be rcv_buffer 0) 315 | end else payload_len 316 | in 317 | 318 | Logger.debug (fun m -> m "Real PAYLOAD LEN : %d" payload_len); 319 | 320 | (* get the masking key (32 bits) *) 321 | let masking_key = Bytes.create 4 in 322 | ignore (recv_bytes sock masking_key 0 4); 323 | 324 | Logger.debug (fun m -> m "MASKING KEY : 0x%02x 0x%02x 0x%02x 0x%02x" 325 | (int_of_char (Bytes.get masking_key 0)) 326 | (int_of_char (Bytes.get masking_key 1)) 327 | (int_of_char (Bytes.get masking_key 2)) 328 | (int_of_char (Bytes.get masking_key 3))); 329 | 330 | let data = 331 | if payload_len > 0 then 332 | (* get the data *) 333 | let payload_data = Bytes.create payload_len in 334 | ignore (recv_bytes sock payload_data 0 payload_len); 335 | (* decode the data *) 336 | unmask_data masking_key payload_data 337 | else Bytes.empty 338 | in 339 | 340 | Logger.debug (fun m -> m "DATA : %s" (Bytes.to_string data)); 341 | 342 | { fin; opcode; frame_data = data } 343 | 344 | let receive_message sock = 345 | let msg_type = ref None in 346 | let msg_buffer = Buffer.create 16 in 347 | let rec aux first_frame = 348 | let frame = receive_frame sock in 349 | (* update msg_type and msg_buffer *) 350 | begin match frame.opcode with 351 | | ContinuationFrame -> 352 | if first_frame then 353 | raise (WSError "The opcode Continuation cannot be used in the first frame of a message"); 354 | Buffer.add_bytes msg_buffer frame.frame_data 355 | | TextFrame -> 356 | if not first_frame then 357 | raise (WSError "The opcode TextFrame can only be used in the first frame of a message"); 358 | msg_type := Some TextMsg; 359 | Buffer.add_bytes msg_buffer frame.frame_data 360 | | BinaryFrame -> 361 | if not first_frame then 362 | raise (WSError "The opcode BinaryFrame can only be used in the first frame of a message"); 363 | msg_type := Some BinaryMsg; 364 | Buffer.add_bytes msg_buffer frame.frame_data 365 | | Close -> ignore (do_close sock frame) 366 | | Ping -> ignore (send_pong sock frame.frame_data) 367 | | Pong -> 368 | let string_data = Bytes.to_string frame.frame_data in 369 | Logger.debug (fun m -> m "%s" ("Received pong from sock with content : " ^ string_data)) 370 | | ControlFrame i -> raise (NotImplemented ("Unknown opcode " ^ (string_of_int i))) 371 | | NonControlFrame i -> raise (NotImplemented ("Unknown opcode " ^ (string_of_int i))) 372 | end; 373 | 374 | (* if the connection has been closed, stop listening and return the message *) 375 | if closed_in sock then 376 | match !msg_type with 377 | | None -> None 378 | | Some typ -> 379 | Some { msg_typ = typ; msg_data = Buffer.to_bytes msg_buffer } 380 | else if is_controlop frame.opcode 381 | (* if the last frame was a control frame we do not change the value 382 | of first_frame, else it is no longer the first frame of the message *) 383 | then aux first_frame 384 | else if frame.fin 385 | (* if we are done, return the message *) 386 | then match !msg_type with 387 | | None -> assert false 388 | | Some typ -> 389 | Some { msg_typ = typ; msg_data = Buffer.to_bytes msg_buffer } 390 | (* else continue reading new frames *) 391 | else aux false 392 | in aux true 393 | -------------------------------------------------------------------------------- /test/Makefile: -------------------------------------------------------------------------------- 1 | include ../config 2 | 3 | define find_rec 4 | $(shell find * -name "$(1)") 5 | endef 6 | 7 | INCLUDES += unix.cma str.cma -I ../lib websocketml.cma 8 | 9 | BYTES = test_base64.byte test_sha1.byte 10 | 11 | all: $(BYTES) 12 | 13 | %.byte: %.ml 14 | $(OCAMLC) $(OCAMLFLAGS) -o $@ $(INCLUDES) $< 15 | 16 | run: all 17 | @$(eval TESTS := $(call find_rec,*.byte)) 18 | @$(eval ntests := $(words $(TESTS))) 19 | @\ 20 | COUNTER=1; \ 21 | echo; \ 22 | echo Number of tests : $(ntests); \ 23 | echo; \ 24 | for test in $(TESTS); do \ 25 | echo ---------- Test $$COUNTER/$(ntests) : $$test ; \ 26 | ./$$test ; \ 27 | if [ $$? -eq 0 ] ; then echo --- OK ; else echo NOT OK ; echo exiting ... ; break ; fi ; \ 28 | echo ; \ 29 | COUNTER=$$(($$COUNTER+1)) ; \ 30 | done 31 | @echo Passed all tests 32 | 33 | clean: 34 | @rm -f $(call find_rec,*.annot) $(call find_rec,*.cm[iox]) 35 | @rm -f $(call find_rec,*.byte) 36 | @rm -f .depend 37 | 38 | cleanall realclean mrproper: clean 39 | 40 | .depend: 41 | @$(OCAMLDEP) $(INCLUDES) $(call find_rec,*.ml) $(call find_rec,*.mli) \ 42 | > .depend 43 | 44 | -include .depend 45 | -------------------------------------------------------------------------------- /test/test_base64.ml: -------------------------------------------------------------------------------- 1 | let _ = 2 | let tests = [ 3 | (* decoded, encoded *) 4 | "", ""; 5 | "f", "Zg=="; 6 | "fo", "Zm8="; 7 | "foo", "Zm9v"; 8 | "foob", "Zm9vYg=="; 9 | "fooba", "Zm9vYmE="; 10 | "foobar", "Zm9vYmFy"; 11 | ] in 12 | print_endline "Test encoding: "; 13 | let ok_enc = List.fold_left (fun ok (decoded, encoded) -> 14 | let res = Base64.encode decoded in 15 | let test_ok = res = encoded in 16 | Printf.printf "BASE64(\"%s\") = \"%s\" (expected \"%s\") %s\n" 17 | decoded res encoded (if test_ok then "OK" else "NOT OK"); 18 | ok && test_ok 19 | ) true tests 20 | in 21 | print_newline (); 22 | 23 | print_endline "Test decoding: "; 24 | let ok_dec = List.fold_left (fun ok (decoded, encoded) -> 25 | let res = Base64.decode encoded in 26 | let test_ok = res = decoded in 27 | Printf.printf "BASE64⁻¹(\"%s\") = \"%s\" (expected \"%s\") %s\n" 28 | encoded res decoded (if res = decoded then "OK" else "NOT OK"); 29 | ok && test_ok 30 | ) true tests 31 | in 32 | print_newline (); 33 | 34 | if not ok_enc || not ok_dec then exit 1; 35 | -------------------------------------------------------------------------------- /test/test_sha1.ml: -------------------------------------------------------------------------------- 1 | let _ = 2 | 3 | let int32_of_hex_string s = 4 | Int32.of_int (int_of_string ("0x" ^ s)) 5 | in 6 | 7 | let bytes_of_hex_string r = 8 | let hex_strings = String.split_on_char ' ' r in 9 | let hex_ints = List.map int32_of_hex_string hex_strings in 10 | let res = Bytes.create (List.length hex_ints * 4) in 11 | List.iteri (fun i v -> Bytes.set_int32_be res (4*i) v) hex_ints; 12 | res 13 | in 14 | 15 | let run_test clear hashed = 16 | let res = Bytes.of_string (Sha1.hash clear) in 17 | let expected = bytes_of_hex_string hashed in 18 | Printf.printf "SHA1(\"%s\") =\n%a\nexpected\n%a\n" 19 | clear Sha1.show_byte res Sha1.show_byte expected; 20 | res = expected 21 | in 22 | 23 | let ok = run_test "" "da39a3ee 5e6b4b0d 3255bfef 95601890 afd80709" in 24 | 25 | print_endline (if ok then "OK\n" else "NOT OK\n"); 26 | 27 | let ok = ok && 28 | run_test "abc" "a9993e36 4706816a ba3e2571 7850c26c 9cd0d89d" in 29 | 30 | print_endline (if ok then "OK\n" else "NOT OK\n"); 31 | 32 | let ok = ok && 33 | run_test "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" 34 | "84983e44 1c3bd26e baae4aa1 f95129e5 e54670f1" in 35 | 36 | print_endline (if ok then "OK\n" else "NOT OK\n"); 37 | 38 | let ok = ok && 39 | run_test "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" 40 | "a49b2446 a02c645b f419f995 b6709125 3a04a259" in 41 | 42 | print_endline (if ok then "OK\n" else "NOT OK\n"); 43 | 44 | (* let ok = ok && 45 | run_test (String.make 1000000 'a') 46 | "34aa973c d4c4daa4 f61eeb2b dbad2731 6534016f" in 47 | 48 | print_endline (if ok then "OK\n" else "NOT OK\n"); *) 49 | 50 | (* pass : trust me. If you don't, take an 8 min coffee brake and run it 51 | (disable the printing of the decoded string before) *) 52 | (* let ok = ok && 53 | run_test 54 | (* generate a 1GB string *) 55 | (String.init (16777216*64) 56 | (fun i -> 57 | String.get 58 | "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmno" 59 | (i mod 64))) 60 | "7789f0c9 ef7bfc40 d9331114 3dfbe69e 2017f592" in *) 61 | 62 | if not ok then exit 1 63 | -------------------------------------------------------------------------------- /websocketml.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "websocketml" 3 | version: "0.1.1" 4 | synopsis: "A simple websocket library for OCaml with no dependency" 5 | maintainer: "ismailbennani " 6 | authors: "ismailbennani " 7 | license: "CeCILL-C" 8 | homepage: "https://github.com/ismailbennani/websocketml" 9 | bug-reports: "https://github.com/ismailbennani/websocketml/issues" 10 | depends: [ 11 | "ocaml" { >= "4.08" } 12 | "ocamlfind" {build} 13 | ] 14 | build: [ 15 | ["./configure" "--prefix=%{prefix}%"] 16 | [make] 17 | ] 18 | install: [make "install"] 19 | dev-repo: "git+https://github.com/ismailbennani/websocketml" 20 | --------------------------------------------------------------------------------