├── .depend ├── .gitignore ├── .ocamlinit ├── INSTALL ├── LICENSE ├── META.in ├── Makefile ├── Makefile.defs ├── README.md ├── cookie_lexer.mli ├── cookie_lexer.mll ├── debian ├── .gitignore ├── changelog ├── compat ├── control ├── copyright ├── dirs.in ├── examples ├── rules └── source │ └── format ├── examples ├── Makefile ├── always_ok_daemon.ml ├── basic_auth.ml ├── chdir.ml ├── client_address.ml ├── damned_recursion.ml ├── dump_args.ml ├── highlander.ml ├── oo_daemon.ml ├── threads.ml ├── timeout.ml └── webfsd.ml ├── http_common.ml ├── http_common.mli ├── http_constants.ml ├── http_constants.mli ├── http_daemon.ml ├── http_daemon.mli ├── http_message.ml ├── http_message.mli ├── http_misc.ml ├── http_misc.mli ├── http_parser.ml ├── http_parser.mli ├── http_parser_sanity.ml ├── http_parser_sanity.mli ├── http_request.ml ├── http_request.mli ├── http_response.ml ├── http_response.mli ├── http_tcp_server.ml ├── http_tcp_server.mli ├── http_threaded_tcp_server.mli ├── http_types.ml ├── http_types.mli ├── http_user_agent.ml ├── http_user_agent.mli ├── mt ├── .gitignore └── http_threaded_tcp_server.ml ├── non_mt ├── .gitignore └── http_threaded_tcp_server.ml └── opam /.depend: -------------------------------------------------------------------------------- 1 | cookie_lexer.cmo: cookie_lexer.cmi 2 | cookie_lexer.cmx: cookie_lexer.cmi 3 | http_common.cmo: http_types.cmi http_constants.cmi http_common.cmi 4 | http_common.cmx: http_types.cmx http_constants.cmx http_common.cmi 5 | http_constants.cmo: http_constants.cmi 6 | http_constants.cmx: http_constants.cmi 7 | http_daemon.cmo: http_types.cmi http_tcp_server.cmi http_request.cmi \ 8 | http_parser_sanity.cmi http_parser.cmi http_misc.cmi http_constants.cmi \ 9 | http_common.cmi http_daemon.cmi 10 | http_daemon.cmx: http_types.cmx http_tcp_server.cmx http_request.cmx \ 11 | http_parser_sanity.cmx http_parser.cmx http_misc.cmx http_constants.cmx \ 12 | http_common.cmx http_daemon.cmi 13 | http_message.cmo: http_types.cmi http_parser_sanity.cmi http_misc.cmi \ 14 | http_constants.cmi http_common.cmi http_message.cmi 15 | http_message.cmx: http_types.cmx http_parser_sanity.cmx http_misc.cmx \ 16 | http_constants.cmx http_common.cmx http_message.cmi 17 | http_misc.cmo: http_types.cmi http_misc.cmi 18 | http_misc.cmx: http_types.cmx http_misc.cmi 19 | http_parser.cmo: http_types.cmi http_parser_sanity.cmi http_constants.cmi \ 20 | http_common.cmi cookie_lexer.cmi http_parser.cmi 21 | http_parser.cmx: http_types.cmx http_parser_sanity.cmx http_constants.cmx \ 22 | http_common.cmx cookie_lexer.cmx http_parser.cmi 23 | http_parser_sanity.cmo: http_types.cmi http_constants.cmi \ 24 | http_parser_sanity.cmi 25 | http_parser_sanity.cmx: http_types.cmx http_constants.cmx \ 26 | http_parser_sanity.cmi 27 | http_request.cmo: http_types.cmi http_parser.cmi http_misc.cmi \ 28 | http_message.cmi http_common.cmi http_request.cmi 29 | http_request.cmx: http_types.cmx http_parser.cmx http_misc.cmx \ 30 | http_message.cmx http_common.cmx http_request.cmi 31 | http_response.cmo: http_types.cmi http_misc.cmi http_message.cmi \ 32 | http_daemon.cmi http_constants.cmi http_common.cmi http_response.cmi 33 | http_response.cmx: http_types.cmx http_misc.cmx http_message.cmx \ 34 | http_daemon.cmx http_constants.cmx http_common.cmx http_response.cmi 35 | http_tcp_server.cmo: http_threaded_tcp_server.cmi http_tcp_server.cmi 36 | http_tcp_server.cmx: http_threaded_tcp_server.cmi http_tcp_server.cmi 37 | http_types.cmo: http_types.cmi 38 | http_types.cmx: http_types.cmi 39 | http_user_agent.cmo: http_parser.cmi http_misc.cmi http_common.cmi \ 40 | http_user_agent.cmi 41 | http_user_agent.cmx: http_parser.cmx http_misc.cmx http_common.cmx \ 42 | http_user_agent.cmi 43 | cookie_lexer.cmi: 44 | http_common.cmi: http_types.cmi 45 | http_constants.cmi: http_types.cmi 46 | http_daemon.cmi: http_types.cmi 47 | http_message.cmi: http_types.cmi 48 | http_misc.cmi: 49 | http_parser.cmi: http_types.cmi 50 | http_parser_sanity.cmi: 51 | http_request.cmi: http_types.cmi 52 | http_response.cmi: http_types.cmi 53 | http_tcp_server.cmi: http_types.cmi 54 | http_threaded_tcp_server.cmi: 55 | http_types.cmi: 56 | http_user_agent.cmi: http_types.cmi 57 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | doc 2 | *.cma 3 | *.cmo 4 | *.cmi 5 | ocamlinit-stamp 6 | META 7 | -------------------------------------------------------------------------------- /.ocamlinit: -------------------------------------------------------------------------------- 1 | #use "topfind";; 2 | #require "unix";; 3 | #require "pcre";; 4 | #require "netstring";; 5 | #load "http.cma";; 6 | -------------------------------------------------------------------------------- /INSTALL: -------------------------------------------------------------------------------- 1 | 2 | In order to build ocaml-http you will need: 3 | 4 | - the ocaml compiler 5 | [ http://caml.inria.fr ] 6 | 7 | - findlib 8 | [ http://www.ocaml-programming.de/packages/documentation/findlib/ ] 9 | 10 | - ocamlnet 11 | [ http://sourceforge.net/projects/ocamlnet ] 12 | 13 | - pcre-ocaml 14 | [ http://www.ai.univie.ac.at/~markus/home/ocaml_sources.html ] 15 | 16 | To build the bytecode library: 17 | 18 | $ make all 19 | 20 | To build the nativecode library (only if you have an ocaml native code 21 | compiler): 22 | 23 | $ make opt 24 | 25 | To install the built stuff in the OCaml standard library directory (as root): 26 | 27 | # make install 28 | 29 | To install the built stuff in another directory: 30 | 31 | $ make install DESTDIR=another_directory 32 | 33 | To build a debian package of the library (please note that to build a debian 34 | package you will also need some additional stuff like debhelper, fakeroot, ...): 35 | 36 | $ fakeroot debian/rules binary 37 | 38 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | 2 | GNU LIBRARY GENERAL PUBLIC LICENSE 3 | Version 2, June 1991 4 | 5 | Copyright (C) 1991 Free Software Foundation, Inc. 6 | 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 7 | Everyone is permitted to copy and distribute verbatim copies 8 | of this license document, but changing it is not allowed. 9 | 10 | [This is the first released version of the library GPL. It is 11 | numbered 2 because it goes with version 2 of the ordinary GPL.] 12 | 13 | Preamble 14 | 15 | The licenses for most software are designed to take away your 16 | freedom to share and change it. By contrast, the GNU General Public 17 | Licenses are intended to guarantee your freedom to share and change 18 | free software--to make sure the software is free for all its users. 19 | 20 | This license, the Library General Public License, applies to some 21 | specially designated Free Software Foundation software, and to any 22 | other libraries whose authors decide to use it. You can use it for 23 | your libraries, too. 24 | 25 | When we speak of free software, we are referring to freedom, not 26 | price. Our General Public Licenses are designed to make sure that you 27 | have the freedom to distribute copies of free software (and charge for 28 | this service if you wish), that you receive source code or can get it 29 | if you want it, that you can change the software or use pieces of it 30 | in new free programs; and that you know you can do these things. 31 | 32 | To protect your rights, we need to make restrictions that forbid 33 | anyone to deny you these rights or to ask you to surrender the rights. 34 | These restrictions translate to certain responsibilities for you if 35 | you distribute copies of the library, or if you modify it. 36 | 37 | For example, if you distribute copies of the library, whether gratis 38 | or for a fee, you must give the recipients all the rights that we gave 39 | you. You must make sure that they, too, receive or can get the source 40 | code. If you link a program with the library, you must provide 41 | complete object files to the recipients so that they can relink them 42 | with the library, after making changes to the library and recompiling 43 | it. And you must show them these terms so they know their rights. 44 | 45 | Our method of protecting your rights has two steps: (1) copyright 46 | the library, and (2) offer you this license which gives you legal 47 | permission to copy, distribute and/or modify the library. 48 | 49 | Also, for each distributor's protection, we want to make certain 50 | that everyone understands that there is no warranty for this free 51 | library. If the library is modified by someone else and passed on, we 52 | want its recipients to know that what they have is not the original 53 | version, so that any problems introduced by others will not reflect on 54 | the original authors' reputations. 55 | 56 | Finally, any free program is threatened constantly by software 57 | patents. We wish to avoid the danger that companies distributing free 58 | software will individually obtain patent licenses, thus in effect 59 | transforming the program into proprietary software. To prevent this, 60 | we have made it clear that any patent must be licensed for everyone's 61 | free use or not licensed at all. 62 | 63 | Most GNU software, including some libraries, is covered by the ordinary 64 | GNU General Public License, which was designed for utility programs. This 65 | license, the GNU Library General Public License, applies to certain 66 | designated libraries. This license is quite different from the ordinary 67 | one; be sure to read it in full, and don't assume that anything in it is 68 | the same as in the ordinary license. 69 | 70 | The reason we have a separate public license for some libraries is that 71 | they blur the distinction we usually make between modifying or adding to a 72 | program and simply using it. Linking a program with a library, without 73 | changing the library, is in some sense simply using the library, and is 74 | analogous to running a utility program or application program. However, in 75 | a textual and legal sense, the linked executable is a combined work, a 76 | derivative of the original library, and the ordinary General Public License 77 | treats it as such. 78 | 79 | Because of this blurred distinction, using the ordinary General 80 | Public License for libraries did not effectively promote software 81 | sharing, because most developers did not use the libraries. We 82 | concluded that weaker conditions might promote sharing better. 83 | 84 | However, unrestricted linking of non-free programs would deprive the 85 | users of those programs of all benefit from the free status of the 86 | libraries themselves. This Library General Public License is intended to 87 | permit developers of non-free programs to use free libraries, while 88 | preserving your freedom as a user of such programs to change the free 89 | libraries that are incorporated in them. (We have not seen how to achieve 90 | this as regards changes in header files, but we have achieved it as regards 91 | changes in the actual functions of the Library.) The hope is that this 92 | will lead to faster development of free libraries. 93 | 94 | The precise terms and conditions for copying, distribution and 95 | modification follow. Pay close attention to the difference between a 96 | "work based on the library" and a "work that uses the library". The 97 | former contains code derived from the library, while the latter only 98 | works together with the library. 99 | 100 | Note that it is possible for a library to be covered by the ordinary 101 | General Public License rather than by this special one. 102 | 103 | GNU LIBRARY GENERAL PUBLIC LICENSE 104 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 105 | 106 | 0. This License Agreement applies to any software library which 107 | contains a notice placed by the copyright holder or other authorized 108 | party saying it may be distributed under the terms of this Library 109 | General Public License (also called "this License"). Each licensee is 110 | addressed as "you". 111 | 112 | A "library" means a collection of software functions and/or data 113 | prepared so as to be conveniently linked with application programs 114 | (which use some of those functions and data) to form executables. 115 | 116 | The "Library", below, refers to any such software library or work 117 | which has been distributed under these terms. A "work based on the 118 | Library" means either the Library or any derivative work under 119 | copyright law: that is to say, a work containing the Library or a 120 | portion of it, either verbatim or with modifications and/or translated 121 | straightforwardly into another language. (Hereinafter, translation is 122 | included without limitation in the term "modification".) 123 | 124 | "Source code" for a work means the preferred form of the work for 125 | making modifications to it. For a library, complete source code means 126 | all the source code for all modules it contains, plus any associated 127 | interface definition files, plus the scripts used to control compilation 128 | and installation of the library. 129 | 130 | Activities other than copying, distribution and modification are not 131 | covered by this License; they are outside its scope. The act of 132 | running a program using the Library is not restricted, and output from 133 | such a program is covered only if its contents constitute a work based 134 | on the Library (independent of the use of the Library in a tool for 135 | writing it). Whether that is true depends on what the Library does 136 | and what the program that uses the Library does. 137 | 138 | 1. You may copy and distribute verbatim copies of the Library's 139 | complete source code as you receive it, in any medium, provided that 140 | you conspicuously and appropriately publish on each copy an 141 | appropriate copyright notice and disclaimer of warranty; keep intact 142 | all the notices that refer to this License and to the absence of any 143 | warranty; and distribute a copy of this License along with the 144 | Library. 145 | 146 | You may charge a fee for the physical act of transferring a copy, 147 | and you may at your option offer warranty protection in exchange for a 148 | fee. 149 | 150 | 2. You may modify your copy or copies of the Library or any portion 151 | of it, thus forming a work based on the Library, and copy and 152 | distribute such modifications or work under the terms of Section 1 153 | above, provided that you also meet all of these conditions: 154 | 155 | a) The modified work must itself be a software library. 156 | 157 | b) You must cause the files modified to carry prominent notices 158 | stating that you changed the files and the date of any change. 159 | 160 | c) You must cause the whole of the work to be licensed at no 161 | charge to all third parties under the terms of this License. 162 | 163 | d) If a facility in the modified Library refers to a function or a 164 | table of data to be supplied by an application program that uses 165 | the facility, other than as an argument passed when the facility 166 | is invoked, then you must make a good faith effort to ensure that, 167 | in the event an application does not supply such function or 168 | table, the facility still operates, and performs whatever part of 169 | its purpose remains meaningful. 170 | 171 | (For example, a function in a library to compute square roots has 172 | a purpose that is entirely well-defined independent of the 173 | application. Therefore, Subsection 2d requires that any 174 | application-supplied function or table used by this function must 175 | be optional: if the application does not supply it, the square 176 | root function must still compute square roots.) 177 | 178 | These requirements apply to the modified work as a whole. If 179 | identifiable sections of that work are not derived from the Library, 180 | and can be reasonably considered independent and separate works in 181 | themselves, then this License, and its terms, do not apply to those 182 | sections when you distribute them as separate works. But when you 183 | distribute the same sections as part of a whole which is a work based 184 | on the Library, the distribution of the whole must be on the terms of 185 | this License, whose permissions for other licensees extend to the 186 | entire whole, and thus to each and every part regardless of who wrote 187 | it. 188 | 189 | Thus, it is not the intent of this section to claim rights or contest 190 | your rights to work written entirely by you; rather, the intent is to 191 | exercise the right to control the distribution of derivative or 192 | collective works based on the Library. 193 | 194 | In addition, mere aggregation of another work not based on the Library 195 | with the Library (or with a work based on the Library) on a volume of 196 | a storage or distribution medium does not bring the other work under 197 | the scope of this License. 198 | 199 | 3. You may opt to apply the terms of the ordinary GNU General Public 200 | License instead of this License to a given copy of the Library. To do 201 | this, you must alter all the notices that refer to this License, so 202 | that they refer to the ordinary GNU General Public License, version 2, 203 | instead of to this License. (If a newer version than version 2 of the 204 | ordinary GNU General Public License has appeared, then you can specify 205 | that version instead if you wish.) Do not make any other change in 206 | these notices. 207 | 208 | Once this change is made in a given copy, it is irreversible for 209 | that copy, so the ordinary GNU General Public License applies to all 210 | subsequent copies and derivative works made from that copy. 211 | 212 | This option is useful when you wish to copy part of the code of 213 | the Library into a program that is not a library. 214 | 215 | 4. You may copy and distribute the Library (or a portion or 216 | derivative of it, under Section 2) in object code or executable form 217 | under the terms of Sections 1 and 2 above provided that you accompany 218 | it with the complete corresponding machine-readable source code, which 219 | must be distributed under the terms of Sections 1 and 2 above on a 220 | medium customarily used for software interchange. 221 | 222 | If distribution of object code is made by offering access to copy 223 | from a designated place, then offering equivalent access to copy the 224 | source code from the same place satisfies the requirement to 225 | distribute the source code, even though third parties are not 226 | compelled to copy the source along with the object code. 227 | 228 | 5. A program that contains no derivative of any portion of the 229 | Library, but is designed to work with the Library by being compiled or 230 | linked with it, is called a "work that uses the Library". Such a 231 | work, in isolation, is not a derivative work of the Library, and 232 | therefore falls outside the scope of this License. 233 | 234 | However, linking a "work that uses the Library" with the Library 235 | creates an executable that is a derivative of the Library (because it 236 | contains portions of the Library), rather than a "work that uses the 237 | library". The executable is therefore covered by this License. 238 | Section 6 states terms for distribution of such executables. 239 | 240 | When a "work that uses the Library" uses material from a header file 241 | that is part of the Library, the object code for the work may be a 242 | derivative work of the Library even though the source code is not. 243 | Whether this is true is especially significant if the work can be 244 | linked without the Library, or if the work is itself a library. The 245 | threshold for this to be true is not precisely defined by law. 246 | 247 | If such an object file uses only numerical parameters, data 248 | structure layouts and accessors, and small macros and small inline 249 | functions (ten lines or less in length), then the use of the object 250 | file is unrestricted, regardless of whether it is legally a derivative 251 | work. (Executables containing this object code plus portions of the 252 | Library will still fall under Section 6.) 253 | 254 | Otherwise, if the work is a derivative of the Library, you may 255 | distribute the object code for the work under the terms of Section 6. 256 | Any executables containing that work also fall under Section 6, 257 | whether or not they are linked directly with the Library itself. 258 | 259 | 6. As an exception to the Sections above, you may also compile or 260 | link a "work that uses the Library" with the Library to produce a 261 | work containing portions of the Library, and distribute that work 262 | under terms of your choice, provided that the terms permit 263 | modification of the work for the customer's own use and reverse 264 | engineering for debugging such modifications. 265 | 266 | You must give prominent notice with each copy of the work that the 267 | Library is used in it and that the Library and its use are covered by 268 | this License. You must supply a copy of this License. If the work 269 | during execution displays copyright notices, you must include the 270 | copyright notice for the Library among them, as well as a reference 271 | directing the user to the copy of this License. Also, you must do one 272 | of these things: 273 | 274 | a) Accompany the work with the complete corresponding 275 | machine-readable source code for the Library including whatever 276 | changes were used in the work (which must be distributed under 277 | Sections 1 and 2 above); and, if the work is an executable linked 278 | with the Library, with the complete machine-readable "work that 279 | uses the Library", as object code and/or source code, so that the 280 | user can modify the Library and then relink to produce a modified 281 | executable containing the modified Library. (It is understood 282 | that the user who changes the contents of definitions files in the 283 | Library will not necessarily be able to recompile the application 284 | to use the modified definitions.) 285 | 286 | b) Accompany the work with a written offer, valid for at 287 | least three years, to give the same user the materials 288 | specified in Subsection 6a, above, for a charge no more 289 | than the cost of performing this distribution. 290 | 291 | c) If distribution of the work is made by offering access to copy 292 | from a designated place, offer equivalent access to copy the above 293 | specified materials from the same place. 294 | 295 | d) Verify that the user has already received a copy of these 296 | materials or that you have already sent this user a copy. 297 | 298 | For an executable, the required form of the "work that uses the 299 | Library" must include any data and utility programs needed for 300 | reproducing the executable from it. However, as a special exception, 301 | the source code distributed need not include anything that is normally 302 | distributed (in either source or binary form) with the major 303 | components (compiler, kernel, and so on) of the operating system on 304 | which the executable runs, unless that component itself accompanies 305 | the executable. 306 | 307 | It may happen that this requirement contradicts the license 308 | restrictions of other proprietary libraries that do not normally 309 | accompany the operating system. Such a contradiction means you cannot 310 | use both them and the Library together in an executable that you 311 | distribute. 312 | 313 | 7. You may place library facilities that are a work based on the 314 | Library side-by-side in a single library together with other library 315 | facilities not covered by this License, and distribute such a combined 316 | library, provided that the separate distribution of the work based on 317 | the Library and of the other library facilities is otherwise 318 | permitted, and provided that you do these two things: 319 | 320 | a) Accompany the combined library with a copy of the same work 321 | based on the Library, uncombined with any other library 322 | facilities. This must be distributed under the terms of the 323 | Sections above. 324 | 325 | b) Give prominent notice with the combined library of the fact 326 | that part of it is a work based on the Library, and explaining 327 | where to find the accompanying uncombined form of the same work. 328 | 329 | 8. You may not copy, modify, sublicense, link with, or distribute 330 | the Library except as expressly provided under this License. Any 331 | attempt otherwise to copy, modify, sublicense, link with, or 332 | distribute the Library is void, and will automatically terminate your 333 | rights under this License. However, parties who have received copies, 334 | or rights, from you under this License will not have their licenses 335 | terminated so long as such parties remain in full compliance. 336 | 337 | 9. You are not required to accept this License, since you have not 338 | signed it. However, nothing else grants you permission to modify or 339 | distribute the Library or its derivative works. These actions are 340 | prohibited by law if you do not accept this License. Therefore, by 341 | modifying or distributing the Library (or any work based on the 342 | Library), you indicate your acceptance of this License to do so, and 343 | all its terms and conditions for copying, distributing or modifying 344 | the Library or works based on it. 345 | 346 | 10. Each time you redistribute the Library (or any work based on the 347 | Library), the recipient automatically receives a license from the 348 | original licensor to copy, distribute, link with or modify the Library 349 | subject to these terms and conditions. You may not impose any further 350 | restrictions on the recipients' exercise of the rights granted herein. 351 | You are not responsible for enforcing compliance by third parties to 352 | this License. 353 | 354 | 11. If, as a consequence of a court judgment or allegation of patent 355 | infringement or for any other reason (not limited to patent issues), 356 | conditions are imposed on you (whether by court order, agreement or 357 | otherwise) that contradict the conditions of this License, they do not 358 | excuse you from the conditions of this License. If you cannot 359 | distribute so as to satisfy simultaneously your obligations under this 360 | License and any other pertinent obligations, then as a consequence you 361 | may not distribute the Library at all. For example, if a patent 362 | license would not permit royalty-free redistribution of the Library by 363 | all those who receive copies directly or indirectly through you, then 364 | the only way you could satisfy both it and this License would be to 365 | refrain entirely from distribution of the Library. 366 | 367 | If any portion of this section is held invalid or unenforceable under any 368 | particular circumstance, the balance of the section is intended to apply, 369 | and the section as a whole is intended to apply in other circumstances. 370 | 371 | It is not the purpose of this section to induce you to infringe any 372 | patents or other property right claims or to contest validity of any 373 | such claims; this section has the sole purpose of protecting the 374 | integrity of the free software distribution system which is 375 | implemented by public license practices. Many people have made 376 | generous contributions to the wide range of software distributed 377 | through that system in reliance on consistent application of that 378 | system; it is up to the author/donor to decide if he or she is willing 379 | to distribute software through any other system and a licensee cannot 380 | impose that choice. 381 | 382 | This section is intended to make thoroughly clear what is believed to 383 | be a consequence of the rest of this License. 384 | 385 | 12. If the distribution and/or use of the Library is restricted in 386 | certain countries either by patents or by copyrighted interfaces, the 387 | original copyright holder who places the Library under this License may add 388 | an explicit geographical distribution limitation excluding those countries, 389 | so that distribution is permitted only in or among countries not thus 390 | excluded. In such case, this License incorporates the limitation as if 391 | written in the body of this License. 392 | 393 | 13. The Free Software Foundation may publish revised and/or new 394 | versions of the Library General Public License from time to time. 395 | Such new versions will be similar in spirit to the present version, 396 | but may differ in detail to address new problems or concerns. 397 | 398 | Each version is given a distinguishing version number. If the Library 399 | specifies a version number of this License which applies to it and 400 | "any later version", you have the option of following the terms and 401 | conditions either of that version or of any later version published by 402 | the Free Software Foundation. If the Library does not specify a 403 | license version number, you may choose any version ever published by 404 | the Free Software Foundation. 405 | 406 | 14. If you wish to incorporate parts of the Library into other free 407 | programs whose distribution conditions are incompatible with these, 408 | write to the author to ask for permission. For software which is 409 | copyrighted by the Free Software Foundation, write to the Free 410 | Software Foundation; we sometimes make exceptions for this. Our 411 | decision will be guided by the two goals of preserving the free status 412 | of all derivatives of our free software and of promoting the sharing 413 | and reuse of software generally. 414 | 415 | NO WARRANTY 416 | 417 | 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO 418 | WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. 419 | EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR 420 | OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY 421 | KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE 422 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 423 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE 424 | LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME 425 | THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 426 | 427 | 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN 428 | WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY 429 | AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU 430 | FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR 431 | CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE 432 | LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING 433 | RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A 434 | FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF 435 | SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH 436 | DAMAGES. 437 | 438 | END OF TERMS AND CONDITIONS 439 | 440 | How to Apply These Terms to Your New Libraries 441 | 442 | If you develop a new library, and you want it to be of the greatest 443 | possible use to the public, we recommend making it free software that 444 | everyone can redistribute and change. You can do so by permitting 445 | redistribution under these terms (or, alternatively, under the terms of the 446 | ordinary General Public License). 447 | 448 | To apply these terms, attach the following notices to the library. It is 449 | safest to attach them to the start of each source file to most effectively 450 | convey the exclusion of warranty; and each file should have at least the 451 | "copyright" line and a pointer to where the full notice is found. 452 | 453 | 454 | Copyright (C) 455 | 456 | This library is free software; you can redistribute it and/or 457 | modify it under the terms of the GNU Library General Public 458 | License as published by the Free Software Foundation; either 459 | version 2 of the License, or (at your option) any later version. 460 | 461 | This library is distributed in the hope that it will be useful, 462 | but WITHOUT ANY WARRANTY; without even the implied warranty of 463 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 464 | Library General Public License for more details. 465 | 466 | You should have received a copy of the GNU Library General Public 467 | License along with this library; if not, write to the Free Software 468 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 469 | 470 | Also add information on how to contact you by electronic and paper mail. 471 | 472 | You should also get your employer (if you work as a programmer) or your 473 | school, if any, to sign a "copyright disclaimer" for the library, if 474 | necessary. Here is a sample; alter the names: 475 | 476 | Yoyodyne, Inc., hereby disclaims all copyright interest in the 477 | library `Frob' (a library for tweaking knobs) written by James Random Hacker. 478 | 479 | , 1 April 1990 480 | Ty Coon, President of Vice 481 | 482 | That's all there is to it! 483 | 484 | -------------------------------------------------------------------------------- /META.in: -------------------------------------------------------------------------------- 1 | description = "OCaml HTTP daemon library" 2 | version = "@DISTVERSION@" 3 | requires = "unix,pcre,netstring" 4 | requires(mt) = "unix,pcre,netstring,threads" 5 | archive(byte) = "http.cma" 6 | archive(native) = "http.cmxa" 7 | archive(mt,byte) = "http_mt.cma" 8 | archive(mt,native) = "http_mt.cmxa" 9 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | include Makefile.defs 2 | export SHELL=/bin/bash 3 | 4 | MODULES = \ 5 | http_constants \ 6 | http_types \ 7 | http_parser_sanity \ 8 | http_misc \ 9 | http_common \ 10 | http_tcp_server \ 11 | cookie_lexer \ 12 | http_parser \ 13 | http_message \ 14 | http_request \ 15 | http_daemon \ 16 | http_response \ 17 | http_user_agent \ 18 | $(NULL) 19 | 20 | THREADED_SRV = http_threaded_tcp_server 21 | MODULES_MT = $(patsubst http_tcp_server, mt/$(THREADED_SRV) http_tcp_server, $(MODULES)) 22 | MODULES_NON_MT = $(patsubst http_tcp_server, non_mt/$(THREADED_SRV) http_tcp_server, $(MODULES)) 23 | PUBLIC_MODULES = \ 24 | http_types \ 25 | http_common \ 26 | http_message \ 27 | http_request \ 28 | http_daemon \ 29 | http_response \ 30 | http_user_agent 31 | OCAMLDOC_STUFF = *.mli 32 | DOCDIR = doc/html 33 | DOTDIR = doc/dot 34 | TEXDIR = doc/latex 35 | DESTDIR = $(shell $(OCAMLFIND) printconf destdir) 36 | 37 | all: all_non_mt all_mt 38 | opt: opt_non_mt opt_mt 39 | all_non_mt: http.cma 40 | opt_non_mt: http.cmxa 41 | all_mt: http_mt.cma 42 | opt_mt: http_mt.cmxa 43 | world: all opt 44 | doc: all $(DOCDIR)/index.html $(DOTDIR)/ocaml-http.ps $(TEXDIR)/ocaml-http.ps $(OCAMLDOC_STUFF) 45 | $(DOCDIR)/index.html: 46 | $(OCAMLDOC) -html -d $(DOCDIR) $(OCAMLDOC_STUFF) 47 | $(TEXDIR)/ocaml-http.tex: $(OCAMLDOC_STUFF) 48 | $(OCAMLDOC) -latex -o $@ $^ 49 | $(TEXDIR)/ocaml-http.ps: $(TEXDIR)/ocaml-http.tex 50 | cd $(TEXDIR); \ 51 | latex ocaml-http; \ 52 | latex ocaml-http; \ 53 | dvips ocaml-http 54 | $(DOTDIR)/ocaml-http.ps: $(DOTDIR)/ocaml-http.dot 55 | $(DOT) -Tps $< > $@ 56 | $(DOTDIR)/ocaml-http.dot: *.ml *.mli 57 | $(OCAMLDOC) -dot -o $(DOTDIR)/ocaml-http.dot *.ml *.mli 58 | 59 | examples: 60 | $(MAKE) -C examples/ 61 | examples.opt: 62 | $(MAKE) -C examples/ opt 63 | 64 | include .depend 65 | 66 | depend: 67 | $(OCAMLDEP) *.ml *.mli > .depend 68 | 69 | %.ml: %.mll 70 | $(OCAMLLEX) $< 71 | %.cmi: %.mli 72 | $(OCAMLC) -c $< 73 | %.cmo: %.ml %.cmi 74 | $(OCAMLC) -c $< 75 | %.cmx: %.ml %.cmi 76 | $(OCAMLOPT) -c $< 77 | 78 | non_mt/$(THREADED_SRV).cmo: non_mt/$(THREADED_SRV).ml $(THREADED_SRV).cmi 79 | cp $(THREADED_SRV).{cmi,mli} non_mt/ 80 | $(OCAMLC) -c $< 81 | non_mt/$(THREADED_SRV).cmx: non_mt/$(THREADED_SRV).ml $(THREADED_SRV).cmi 82 | cp $(THREADED_SRV).{cmi,mli} non_mt/ 83 | $(OCAMLOPT) -c $< 84 | 85 | mt/$(THREADED_SRV).cmo: mt/$(THREADED_SRV).ml $(THREADED_SRV).cmi 86 | cp $(THREADED_SRV).{cmi,mli} mt/ 87 | $(OCAMLC) $(THREADS_FLAGS) -c $< 88 | mt/$(THREADED_SRV).cmx: mt/$(THREADED_SRV).ml $(THREADED_SRV).cmi 89 | cp $(THREADED_SRV).{cmi,mli} mt/ 90 | $(OCAMLOPT) $(THREADS_FLAGS) -c $< 91 | 92 | http.cma: $(patsubst %,%.cmo,$(MODULES_NON_MT)) 93 | $(OCAMLC) -a -o $@ $^ 94 | http.cmxa: $(patsubst %,%.cmx,$(MODULES_NON_MT)) 95 | $(OCAMLOPT) -a -o $@ $^ 96 | http_mt.cma: $(patsubst %,%.cmo,$(MODULES_MT)) 97 | $(OCAMLC) -a -o $@ $^ 98 | http_mt.cmxa: $(patsubst %,%.cmx,$(MODULES_MT)) 99 | $(OCAMLOPT) -a -o $@ $^ 100 | 101 | meta: META 102 | META: META.in 103 | cat META.in | sed -e 's/@DISTVERSION@/$(DISTVERSION)/' > META 104 | 105 | clean: 106 | $(MAKE) -C examples/ clean 107 | for d in . mt non_mt; do \ 108 | rm -f $$d/*.cm[ioax] $$d/*.cmxa $$d/*.[ao] $$d/test{,.opt}; \ 109 | done 110 | rm -f {mt,non_mt}/$(THREADED_SRV).mli 111 | docclean: 112 | -rm -f \ 113 | $(DOCDIR)/*.html $(DOCDIR)/*.css \ 114 | $(DOTDIR)/*.dot $(DOTDIR)/*.ps \ 115 | $(TEXDIR)/*.{dvi,ps,ps.gz,pdf,aux,log,out,toc,tmp,haux,sty,tex} 116 | distclean: clean 117 | $(MAKE) -C examples/ distclean 118 | rm -f META 119 | dist: distreal distrm 120 | distdoc: all doc 121 | if [ -d $(DISTDIR) ]; then rm -rf $(DISTDIR); else true; fi 122 | mkdir -p $(DISTDIR)/doc/ 123 | cp -r doc/html/ $(DISTDIR)/doc/ 124 | cp doc/dot/ocaml-http.ps $(DISTDIR)/doc/modules.ps 125 | cp doc/latex/ocaml-http.ps $(DISTDIR)/doc/ 126 | distreal: distdoc distclean depend 127 | for f in \ 128 | $(patsubst %, %.ml, $(MODULES)) \ 129 | $(patsubst %, %.mli, $(MODULES) $(THREADED_SRV)) \ 130 | mt/ non_mt/ $(EXTRA_DIST) examples/ debian/; \ 131 | do \ 132 | cp -r $$f $(DISTDIR)/; \ 133 | done 134 | -find $(DISTDIR)/ -type d -name .svn -exec rm -rf {} \; 135 | tar cvzf $(DISTDIR).tar.gz $(DISTDIR)/ 136 | distrm: 137 | rm -rf $(DISTDIR)/ 138 | deb: docclean distreal 139 | (cd $(DISTDIR)/ && debuild) 140 | rm -rf $(DISTDIR)/ 141 | install: META 142 | mkdir -p $(DESTDIR) 143 | $(OCAMLFIND) install -destdir $(DESTDIR) $(PKGNAME) \ 144 | $(patsubst %, %.mli, $(PUBLIC_MODULES)) \ 145 | $(patsubst %, %.cmi, $(PUBLIC_MODULES)) \ 146 | $(wildcard *.cma *.cmxa *.a) META 147 | 148 | .PHONY: \ 149 | all opt world all_non_mt all_mt opt_non_mt opt_mt \ 150 | examples examples.opt depend clean distclean dist \ 151 | install meta doc deb distreal distrm 152 | 153 | VERSION = 0.1.6 154 | 155 | release: 156 | git tag -a v$(VERSION) -m "Version $(VERSION)." 157 | git push origin v$(VERSION) 158 | opam publish 159 | #opam publish prepare $(NAME_VERSION) $(ARCHIVE) 160 | #cp -t $(NAME_VERSION) descr 161 | #grep -Ev '^(name|version):' opam >$(NAME_VERSION)/opam 162 | #opam publish submit $(NAME_VERSION) 163 | #rm -rf $(NAME_VERSION) 164 | -------------------------------------------------------------------------------- /Makefile.defs: -------------------------------------------------------------------------------- 1 | PKGNAME = http 2 | DISTVERSION = $(shell dpkg-parsechangelog | egrep '^Version: ' | sed 's/^Version: //' | sed 's/-.*//') 3 | 4 | DEBUG_FLAGS = 5 | REQUIRES = unix str pcre netstring 6 | COMMON_FLAGS = $(DEBUG_FLAGS) -package "$(REQUIRES)" 7 | THREADS_FLAGS = -package threads -thread 8 | OCAMLFIND = ocamlfind 9 | OCAMLC = $(OCAMLFIND) ocamlc $(COMMON_FLAGS) 10 | OCAMLOPT = $(OCAMLFIND) ocamlopt $(COMMON_FLAGS) 11 | OCAMLDEP = $(OCAMLFIND) ocamldep $(COMMON_FLAGS) 12 | OCAMLLEX = ocamllex 13 | OCAMLDOC := \ 14 | ocamldoc -stars \ 15 | $(shell $(OCAMLFIND) query -i-format unix) \ 16 | $(shell $(OCAMLFIND) query -i-format pcre) \ 17 | $(shell $(OCAMLFIND) query -i-format netstring) 18 | DOT = dot 19 | 20 | DISTNAME = ocaml-http 21 | DISTDIR = $(DISTNAME)-$(DISTVERSION) 22 | EXTRA_DIST = \ 23 | INSTALL LICENSE README META.in Makefile Makefile.defs \ 24 | .depend 25 | 26 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | OCaml HTTP 2 | ========== 3 | do it yourself (OCaml) HTTP daemon 4 | ---------------------------------- 5 | 6 | OCaml HTTP is an OCaml library freely inspired from Perl's HTTP::Daemon module that permits you to write simple HTTP daemons in OCaml. 7 | 8 | The main API let you define a HTTP daemon specification, which contains, among other parameters, a callback function that is invoked each time a request is received. The callback function will be invoked with an instance of an object representing the received HTTP request and an out_channel connected to the remote HTTP client socket. 9 | 10 | Then you can start your HTTP daemon invoking the main function passing your specification. Each time a client connect to the TCP port bound by your daemon, OCaml HTTP will parse the request and instantiate the request object. If all goes well your callback will be invoked, otherwise appropriate error messages will be sent back to the client without disturbing your callback. 11 | 12 | You can use a lot of facility functions in your callback that permits you to send easily headers, error responses, file, or abstract HTTP response objects. Otherwise you can also choose the 'hard way' and send data directly to the out_channel (expecially useful for sending data incrementally to the client). You can also mix the two approaches. 13 | 14 | Daemon specifications are used also to specify other parameters governing daemon behaviour like: TCP port and address to bind, way of handling incoming requests (handle all of them in a single process, fork a new process or spawn a new thread for each incoming request), timeout, authentication requirements (username and password for HTTP basic authentication). 15 | 16 | OCaml HTTP contains also a tiny implementation of a HTTP client which can be used to retrieve resources via GET HTTP method and to iter on them (useful for huge resources which can't be kept in memory). 17 | 18 | OCaml HTTP is freely distributed under the GNU Library General Public License (GPL) and is available here for download: 19 | 20 | official Debian packages are available: libhttp-ocaml-dev 21 | 22 | To build OCaml HTTP from sources you will need: 23 | * the OCaml compiler 24 | * findlib 25 | * ocamlnet 26 | * pcre-ocaml 27 | -------------------------------------------------------------------------------- /cookie_lexer.mli: -------------------------------------------------------------------------------- 1 | (* 2 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 3 | 4 | Copyright (C) <2002-2010> Stefano Zacchiroli 5 | <2010> Arlen Cuss 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU Library General Public License as 9 | published by the Free Software Foundation, version 2. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU Library General Public License for more details. 15 | 16 | You should have received a copy of the GNU Library General Public 17 | License along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | type cookie_token = 23 | [ `SEP 24 | | `ASSIGNMENT of string * string 25 | | `EOF ] 26 | 27 | val token : Lexing.lexbuf -> cookie_token 28 | 29 | -------------------------------------------------------------------------------- /cookie_lexer.mll: -------------------------------------------------------------------------------- 1 | (* 2 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 3 | 4 | Copyright (C) <2002-2010> Stefano Zacchiroli 5 | <2010> Arlen Cuss 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU Library General Public License as 9 | published by the Free Software Foundation, version 2. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU Library General Public License for more details. 15 | 16 | You should have received a copy of the GNU Library General Public 17 | License along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | { 23 | let quoted_RE = Pcre.regexp "\\\\\"" 24 | type cookie_token = 25 | [ `SEP (* cookie separator (i.e. ";") *) 26 | | `ASSIGNMENT of string * string (* assignment x=y *) 27 | | `EOF (* end of file *) 28 | ] 29 | } 30 | 31 | rule token = parse 32 | | [' ' '\t' '\n' '\r'] { token lexbuf } 33 | | ([^ ' ' '\t' '\n' '\r' '' ''-'' '\'' '=' ';']+ as name) '=' 34 | ([^ '\n' '\r' '' ''-'' ';']* as value) 35 | { 36 | let val_len = String.length value 37 | in 38 | let value = 39 | if val_len>2 && (value.[0]='"' && value.[val_len-1]='"') then 40 | let without_quotes = String.sub value 1 (val_len - 2) 41 | in 42 | Pcre.replace ~rex:quoted_RE ~templ:"\"" without_quotes 43 | else 44 | value 45 | in 46 | `ASSIGNMENT (name,value) 47 | } 48 | | ';' { `SEP } 49 | | eof { `EOF } 50 | 51 | -------------------------------------------------------------------------------- /debian/.gitignore: -------------------------------------------------------------------------------- 1 | dirs 2 | files 3 | libhttp-ocaml-dev* 4 | stamp-makefile-* 5 | -------------------------------------------------------------------------------- /debian/changelog: -------------------------------------------------------------------------------- 1 | ocaml-http (0.1.6-1) unstable; urgency=low 2 | 3 | * ported to ocaml > 3.10 4 | 5 | -- Claudio Sacerdoti Coen Mon, 17 Dec 2018 21:47:55 +1100 6 | 7 | ocaml-http (0.1.5-1) unstable; urgency=low 8 | 9 | * better cookie parsing (as seen in real life!) 10 | * auto-close connections by default 11 | * don't die on empty query strings 12 | 13 | -- Arlen Cuss Fri, 31 Dec 2010 12:58:55 +1100 14 | 15 | ocaml-http (0.1.4-3) unstable; urgency=low 16 | 17 | * rebuild with OCaml 3.11 18 | * debian/control 19 | - refresh build-dependencies for the transition 20 | - add Vcs-* fields pointing to HELM's repository and browser 21 | - add missing ${misc:Depends}, thanks lintian! 22 | - set package section to "ocaml" 23 | - add Homepage field 24 | * debian/rules: use ocaml.mk as a CDBS "rules" snippet 25 | * debian/*.in: use more abstract substitution variable to avoid 26 | hard-coding assumption on stdlib location 27 | 28 | -- Stefano Zacchiroli Thu, 19 Mar 2009 11:06:12 +0100 29 | 30 | ocaml-http (0.1.4-2) unstable; urgency=low 31 | 32 | * change how the ocamldoc API reference is generated: no longer use upstream 33 | Makefile, but rather rely on CDBS 34 | * debian/control 35 | - remove build-dep on texlive stuff and graphviz since now we only ship 36 | HTML version of the API reference 37 | * debian/docs, debian/doc-base 38 | - file removed, the latter will be now automatically generated, the former 39 | would only contain README and CDBS is smart enough to guess it 40 | 41 | -- Stefano Zacchiroli Sun, 09 Sep 2007 12:34:07 +0200 42 | 43 | ocaml-http (0.1.4-1) experimental; urgency=low 44 | 45 | * rebuild against OCaml 3.10 and ocamlnet 2.2 46 | * send internally generated headers as lowercase strings, for consistency 47 | with headers generated via setXXX methods 48 | * add preliminary support for cookies (new "cookies" method added to an 49 | http_request, cookies are parsed upon request creation if a "Cookie:" 50 | header has been received) 51 | * debian/rules 52 | - use ocaml.mk CDBS class 53 | * debian/rules 54 | - build ocamldoc documentation at package build time 55 | * debian/control 56 | - add build-dep on camlp4, which is now in a separate package 57 | - add build-dep for doc generation: graphviz, texlive-latex-recommended, 58 | texlive-base-bin, texlive-latex-extra 59 | * debian/svn-deblayout 60 | - add repository layout information 61 | - bump debhelper dep and compatibility level to 5 62 | 63 | -- Stefano Zacchiroli Mon, 16 Jul 2007 16:19:48 +0200 64 | 65 | ocaml-http (0.1.3-2) unstable; urgency=low 66 | 67 | * debian/control.in 68 | - file removed, no longer needed 69 | * debian/control 70 | - bumped dependencies on pcre-ocaml and ocamlnet 71 | * debian/rules 72 | - binNMU safe substitution of variables in .in files 73 | * debian/dirs 74 | - file removed, will be generated at build time 75 | 76 | -- Stefano Zacchiroli Fri, 15 Sep 2006 00:29:56 +0200 77 | 78 | ocaml-http (0.1.3-1) unstable; urgency=low 79 | 80 | * force bash as SHELL in Makefile, since we rely on bashisms 81 | (closes: bug#381915) 82 | * removed Http_daemon.{start,start'}, they have been deprecated a while ago 83 | in favour of Http_daemon.main 84 | * added 'auto_close' to daemon specifications. When set to true (defaults to 85 | false), makes ocaml-http close every connection with client just after 86 | having executed a callback, no matter if that callback succeeds or fails 87 | with an exception 88 | 89 | -- Stefano Zacchiroli Sun, 20 Aug 2006 18:07:41 +0200 90 | 91 | ocaml-http (0.1.2-4) unstable; urgency=low 92 | 93 | * Rebuilt against ocaml 3.09.2, bumped deps accordingly. 94 | * debian/control 95 | - Bumped Standards-Version to 3.7.2 (no changes needed) 96 | 97 | -- Stefano Zacchiroli Wed, 17 May 2006 05:18:32 +0000 98 | 99 | ocaml-http (0.1.2-3) unstable; urgency=low 100 | 101 | * Rebuilt against OCaml 3.09.1, bumped deps accordingly. 102 | 103 | -- Stefano Zacchiroli Sun, 8 Jan 2006 13:13:07 +0100 104 | 105 | ocaml-http (0.1.2-2) unstable; urgency=low 106 | 107 | * rebuilt with ocaml 3.09 108 | * debian/* 109 | - no more hardcoding of ocaml abi version anywhere 110 | * debian/rules 111 | - use cdbs 112 | 113 | -- Stefano Zacchiroli Sat, 26 Nov 2005 20:28:26 +0100 114 | 115 | ocaml-http (0.1.2-1) unstable; urgency=low 116 | 117 | * avoid exceptions for closing connection twice during finaliztion of 118 | connection objects (thanks to Eric Strokes 119 | for the patch) 120 | 121 | -- Stefano Zacchiroli Wed, 14 Sep 2005 18:03:40 +0200 122 | 123 | ocaml-http (0.1.1-1) unstable; urgency=low 124 | 125 | * added ?default parameter to "param" method 126 | * fixed bug in response status line parsing 127 | * integrated patch for HTTP/1.1 persistent connections from 128 | Eric Cooper : 129 | - added support for persistent connections to http_daemon.ml: server 130 | now loops until End_of_file (or any exception) occurs when trying 131 | to parse the next request 132 | * debian/control 133 | - bumped pcre and ocamlnet dependencies 134 | - bumped standards-version to 3.6.2 135 | 136 | -- Stefano Zacchiroli Wed, 16 Mar 2005 09:24:07 +0100 137 | 138 | ocaml-http (0.1.0-2) unstable; urgency=low 139 | 140 | * rebuilt against ocaml 3.08.3 141 | 142 | -- Stefano Zacchiroli Tue, 29 Mar 2005 11:39:24 +0200 143 | 144 | ocaml-http (0.1.0-1) unstable; urgency=low 145 | 146 | * first debian official package 147 | 148 | -- Stefano Zacchiroli Tue, 8 Feb 2005 22:45:54 +0100 149 | 150 | ocaml-http (0.1.0) unstable; urgency=low 151 | 152 | * added "daemon specifications": a unified way of specifying daemons 153 | behaviour including old parameters of Http_daemon.start together 154 | with authentication requirements and exception handling 155 | * added new way of building daemons starting from specifications, old 156 | ways (e.g. Http_daemon.start) are now deprecated 157 | * added sigpipe handling to avoid daemons dying for uncaught signals 158 | * added exception handler (as part of a daemon specification), it can 159 | be used to ensure that some code is execute before a process/thread 160 | die for uncaught exception (e.g. unlocking a global mutex) 161 | * added authentication requirements (as part of a daemon 162 | specification): an handy way to specify required user name and 163 | password for HTTP basic authentication 164 | * added head_callback to Http_user_agent in order to have access to 165 | response status and headers in HTTP requests 166 | * changed license from GPL to LGPL 167 | * improved ocamldoc documentation and debian packaging 168 | 169 | -- Stefano Zacchiroli Thu, 3 Feb 2005 23:08:14 +0100 170 | 171 | ocaml-http (0.0.10) unstable; urgency=low 172 | 173 | * renamed Http_client module to Http_user_agent to avoid compatibility 174 | issues with Netclient. Renamed that module functions removing 175 | "http_" prefix (e.g., summarizing, Http_client.http_get -> 176 | Http_user_agent.get) 177 | * ported to ocaml 3.08 178 | * debian/control 179 | - bumped standards version to 3.6.1.1 180 | - changed deps to ocaml 3.08 and -nox 181 | 182 | -- Stefano Zacchiroli Thu, 5 Aug 2004 15:06:49 +0200 183 | 184 | ocaml-http (0.0.9) unstable; urgency=low 185 | 186 | * Added support for HTTP Basic authentication 187 | * Restyled Http_daemon API so that correct invocations of them are 188 | statically typechecked 189 | * Added support for HEAD requests to Http_client 190 | * ~addr parameter now support not only ip addresses but also hostnames 191 | * debian/control 192 | - bumped Standards-Version to 3.6.1.0 193 | * debian/rules 194 | - moved debhelper compatibility level to debian/compat 195 | 196 | -- Stefano Zacchiroli Tue, 16 Dec 2003 18:01:41 +0100 197 | 198 | ocaml-http (0.0.8) unstable; urgency=low 199 | 200 | * Added support for "ancient" HTTP requests which specify no HTTP 201 | version 202 | - 'version' method on message now has type 'version option' 203 | * Http_daemon now use debugging prints from Http_common like other 204 | modules 205 | * Added debugging print of requests parse error 206 | * Shutdown server socket on abnormal exit (actually: uncaught 207 | exceptions or SIGTERM received) 208 | * Added a lot of ocamldoc documentation 209 | * Added minimal HTTP 1.0/1.1 client support 210 | 211 | -- Stefano Zacchiroli Fri, 10 Jan 2003 10:36:53 +0100 212 | 213 | ocaml-http (0.0.7) unstable; urgency=low 214 | 215 | * Added support for POST requests 216 | * Implemented a commont 'message' class from which 'request' and 217 | 'response' inherit 218 | * Changed constructor of 'request' objects, requests are now buildable 219 | directly (and only) from an input channel 220 | * Added client IP address information to Http_request.request class 221 | * Added OO daemon interfaces ("daemon" and "connection" classes) 222 | * Use Pcre to perform sanity test on headers instead of home made 223 | parsing 224 | * Callback functions can raise Http_types.Quit to have main daemon 225 | quit 226 | * Case-insensitive handling of header names 227 | 228 | -- Stefano Zacchiroli Wed, 25 Dec 2002 16:22:31 +0100 229 | 230 | ocaml-http (0.0.6) unstable; urgency=low 231 | 232 | * Ship multithreaded and non multithreaded cm{x,}aS 233 | * Added support for multiple binding of the same parameter in request 234 | objects (new method 'paramAll') 235 | * Added support for 'empty' bindings in query arguments (e.g. 236 | "/foo?b=" or "/foo?b") 237 | * Added some sanity checks 238 | * Bumped Standards-Version to 3.5.8 239 | * Use versioned dependencies lib{pcre,ocamlnet}-ocaml-dev- 240 | * Added 'Provides libhttp-ocaml-dev-' 241 | * Removed GPL from debian/copyright, added reference to 242 | /usr/share/common-licenses/GPL 243 | 244 | -- Stefano Zacchiroli Mon, 25 Nov 2002 11:04:49 +0100 245 | 246 | ocaml-http (0.0.5) unstable; urgency=low 247 | 248 | * Fixed bug for HTTP encoded GET parameters which contain '?' or '&' 249 | characters 250 | * Added support for chdir in a given document root before starting 251 | * Added support for multi threaded daemons 252 | * Added a generic 'Http_daemon.respond' function 253 | * Added 'toString' method to response objects 254 | 255 | -- Stefano Zacchiroli Fri, 22 Nov 2002 11:29:37 +0100 256 | 257 | ocaml-http (0.0.3) unstable; urgency=low 258 | 259 | * First release. 260 | 261 | -- Stefano Zacchiroli Sun, 17 Nov 2002 17:41:41 +0100 262 | -------------------------------------------------------------------------------- /debian/compat: -------------------------------------------------------------------------------- 1 | 9 2 | -------------------------------------------------------------------------------- /debian/control: -------------------------------------------------------------------------------- 1 | Source: ocaml-http 2 | Section: ocaml 3 | Priority: optional 4 | Maintainer: Arlen Cuss 5 | Build-Depends: 6 | debhelper (>> 5.0.0), 7 | cdbs, 8 | dh-ocaml, 9 | ocaml-nox, 10 | camlp4, 11 | ocaml-findlib, 12 | libpcre-ocaml-dev, 13 | libocamlnet-ocaml-dev (>= 2.2.9-6) 14 | Standards-Version: 3.7.2 15 | 16 | Package: libhttp-ocaml-dev 17 | Architecture: any 18 | Depends: 19 | ocaml-nox-${F:OCamlABI}, 20 | libpcre-ocaml-dev, 21 | libocamlnet-ocaml-dev, 22 | ${misc:Depends} 23 | Description: OCaml library for writing HTTP servers 24 | OCaml HTTP is a library for the Objective Caml programming language, 25 | used to build simple HTTP servers, largely inspired by Perl's 26 | HTTP::Daemon module. 27 | . 28 | In order to implement an HTTP server, the programmer has to provide a 29 | daemon specification which contains, among other parameters, a callback 30 | function invoked by OCaml HTTP on well-formed HTTP requests received. 31 | HTTP responses can be sent over an out_channel connected with client 32 | socket, accessible from the callback. 33 | . 34 | The library contains also facility functions that helps in creating 35 | well-formed HTTP responses and a tiny HTTP client. 36 | -------------------------------------------------------------------------------- /debian/copyright: -------------------------------------------------------------------------------- 1 | 2 | Authors: Stefano Zacchiroli 3 | Arlen Cuss 4 | 5 | Copyright: 6 | 7 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 8 | 9 | Copyright (C) <2002-2010> Stefano Zacchiroli 10 | Copyright (C) <2010> Arlen Cuss 11 | 12 | OCaml HTTP is distributed under the term of the GNU Library General 13 | Public License version 2, on Debian systems you can find a copy of the 14 | license in: 15 | 16 | /usr/share/common-licenses/LGPL-2 17 | 18 | -------------------------------------------------------------------------------- /debian/dirs.in: -------------------------------------------------------------------------------- 1 | @OCamlStdlibDir@ 2 | -------------------------------------------------------------------------------- /debian/examples: -------------------------------------------------------------------------------- 1 | examples/*.ml 2 | -------------------------------------------------------------------------------- /debian/rules: -------------------------------------------------------------------------------- 1 | #!/usr/bin/make -f 2 | include /usr/share/cdbs/1/class/makefile.mk 3 | include /usr/share/cdbs/1/rules/debhelper.mk 4 | include /usr/share/cdbs/1/rules/ocaml.mk 5 | 6 | PKGNAME = libhttp-ocaml-dev 7 | OCAML_OCAMLDOC_PACKAGES = $(OCAML_LIBDEV_PACKAGES) 8 | DEB_MAKE_BUILD_TARGET = all 9 | ifeq ($(OCAML_HAVE_OCAMLOPT),yes) 10 | DEB_MAKE_BUILD_TARGET += opt 11 | endif 12 | DEB_MAKE_INSTALL_TARGET = install DESTDIR=$(CURDIR)/debian/$(PKGNAME)$(OCAML_STDLIB_DIR) 13 | -------------------------------------------------------------------------------- /debian/source/format: -------------------------------------------------------------------------------- 1 | 3.0 (quilt) 2 | -------------------------------------------------------------------------------- /examples/Makefile: -------------------------------------------------------------------------------- 1 | include ../Makefile.defs 2 | OBJS_NON_MT = ../http.cma 3 | OBJS_NON_MT_OPT = ../http.cmxa 4 | OBJS_MT = ../http_mt.cma 5 | OBJS_MT_OPT = ../http_mt.cmxa 6 | EXAMPLES_FLAGS = -I .. -linkpkg 7 | 8 | EXAMPLES := \ 9 | always_ok_daemon.ml \ 10 | basic_auth.ml \ 11 | chdir.ml \ 12 | client_address.ml \ 13 | damned_recursion.ml \ 14 | dump_args.ml \ 15 | highlander.ml \ 16 | oo_daemon.ml \ 17 | threads.ml \ 18 | timeout.ml \ 19 | webfsd.ml 20 | EXAMPLES := $(patsubst %.ml,%,$(EXAMPLES)) 21 | 22 | all: $(EXAMPLES) 23 | opt: $(patsubst %,%.opt,$(EXAMPLES)) 24 | %: %.ml $(OBJS_NON_MT) 25 | $(OCAMLC) $(EXAMPLES_FLAGS) $(OBJS_NON_MT) -o $@ $< 26 | %.opt: %.ml $(OBJS_NON_MT_OPT) 27 | $(OCAMLOPT) $(EXAMPLES_FLAGS) $(OBJS_NON_MT_OPT) -o $@ $< 28 | 29 | threads: threads.ml $(OBJS_MT) 30 | $(OCAMLC) $(EXAMPLES_FLAGS) $(OBJS_MT) $(THREADS_FLAGS) -o $@ $< 31 | threads.opt: threads.ml $(OBJS_MT_OPT) 32 | $(OCAMLOPT) $(EXAMPLES_FLAGS) $(OBJS_MT_OPT) $(THREADS_FLAGS) -o $@ $< 33 | 34 | damned_recursion: damned_recursion.ml $(OBJS_MT) 35 | $(OCAMLC) $(EXAMPLES_FLAGS) $(OBJS_MT) $(THREADS_FLAGS) -o $@ $< 36 | damned_recursion.opt: damned_recursion.ml $(OBJS_MT_OPT) 37 | $(OCAMLOPT) $(EXAMPLES_FLAGS) $(OBJS_MT_OPT) $(THREADS_FLAGS) -o $@ $< 38 | 39 | distclean: clean 40 | clean: 41 | -rm -f *.cm[ioax] *.o $(EXAMPLES) $(patsubst %,%.opt,$(EXAMPLES)) 42 | -------------------------------------------------------------------------------- /examples/always_ok_daemon.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2004> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU General Public License as published by 9 | the Free Software Foundation; either version 2 of the License, or 10 | (at your option) any later version. 11 | 12 | This program is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | GNU General Public License for more details. 16 | 17 | You should have received a copy of the GNU General Public License 18 | along with this program; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | open Http_types 23 | 24 | (* start an http daemon that alway respond with a 200 status code and an empty 25 | content *) 26 | let spec = 27 | { Http_daemon.default_spec with 28 | callback = (fun _ outchan -> Http_daemon.respond outchan); 29 | port = 9999; 30 | } 31 | 32 | let _ = Http_daemon.main spec 33 | 34 | -------------------------------------------------------------------------------- /examples/basic_auth.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2004> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU General Public License as published by 9 | the Free Software Foundation; either version 2 of the License, or 10 | (at your option) any later version. 11 | 12 | This program is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | GNU General Public License for more details. 16 | 17 | You should have received a copy of the GNU General Public License 18 | along with this program; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | open Http_types 23 | 24 | (* the easy way: specify authentication requirements within a daemon_spec *) 25 | let spec = 26 | { Http_daemon.default_spec with 27 | (* requires basic authentication, username "foo", password "bar" *) 28 | auth = Some ("my realm", `Basic ("foo", "bar")); 29 | callback = (fun _ outchan -> Http_daemon.respond ~body:"secret" outchan); 30 | port = 9999; 31 | } 32 | 33 | (* 34 | (* the hard^Wother way: manual handling of authorization *) 35 | let callback req outchan = 36 | match req#authorization with 37 | | Some (`Basic (username, password)) 38 | when username = "foo" && password = "bar" -> 39 | Http_daemon.respond ~code:(`Code 200) ~body:"secret" outchan 40 | | _ -> raise (Unauthorized "my secret site") 41 | 42 | let spec = 43 | { Http_daemon.default_spec with 44 | callback = callback; 45 | port = 9999; 46 | } 47 | *) 48 | 49 | let _ = Http_daemon.main spec 50 | 51 | -------------------------------------------------------------------------------- /examples/chdir.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2004> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU General Public License as published by 9 | the Free Software Foundation; either version 2 of the License, or 10 | (at your option) any later version. 11 | 12 | This program is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | GNU General Public License for more details. 16 | 17 | You should have received a copy of the GNU General Public License 18 | along with this program; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | open Printf 23 | open Http_types 24 | 25 | let spec = 26 | { Http_daemon.default_spec with 27 | callback = (fun _ outchan -> 28 | Http_daemon.respond ~body:(sprintf "%s\n" (Sys.getcwd ())) outchan); 29 | port = 9999; 30 | root_dir = Some "/etc"; 31 | } 32 | 33 | let _ = Http_daemon.main spec 34 | 35 | -------------------------------------------------------------------------------- /examples/client_address.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2004> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU General Public License as published by 9 | the Free Software Foundation; either version 2 of the License, or 10 | (at your option) any later version. 11 | 12 | This program is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | GNU General Public License for more details. 16 | 17 | You should have received a copy of the GNU General Public License 18 | along with this program; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | open Printf 23 | open Http_types 24 | 25 | let callback req outchan = 26 | let body = 27 | sprintf 28 | "Hi, this is your personal assistant, you are connected from %s:%d\n" 29 | req#clientAddr 30 | req#clientPort 31 | in 32 | let res = new Http_response.response ~body () in 33 | Http_daemon.respond_with res outchan 34 | 35 | let spec = 36 | { Http_daemon.default_spec with 37 | callback = callback; 38 | port = 9999 39 | } 40 | 41 | let _ = Http_daemon.main spec 42 | 43 | -------------------------------------------------------------------------------- /examples/damned_recursion.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2004> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU General Public License as published by 9 | the Free Software Foundation; either version 2 of the License, or 10 | (at your option) any later version. 11 | 12 | This program is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | GNU General Public License for more details. 16 | 17 | You should have received a copy of the GNU General Public License 18 | along with this program; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | open Printf 23 | open Http_types 24 | 25 | let port = 9999 26 | 27 | let callback (req: Http_types.request) outchan = 28 | let i = int_of_string (req#param "x") in 29 | let body = 30 | match i with 31 | | 0 -> "0" 32 | | x when x > 0 -> 33 | let data = 34 | Http_user_agent.get (sprintf "http://127.0.0.1:%d/foo?x=%d" 35 | port (x - 1)) 36 | in 37 | sprintf "%s %d" data x 38 | | _ -> assert false 39 | in 40 | Http_daemon.respond ~code:(`Code 200) ~body outchan; 41 | close_out outchan (* Http_user_agent relies on EOF, not Content-Length *) 42 | 43 | let spec = 44 | { Http_daemon.default_spec with 45 | callback = callback; 46 | port = port; 47 | mode = `Thread; 48 | } 49 | 50 | let _ = Http_daemon.main spec 51 | 52 | -------------------------------------------------------------------------------- /examples/dump_args.ml: -------------------------------------------------------------------------------- 1 | (* 2 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 3 | 4 | Copyright (C) <2002-2007> Stefano Zacchiroli 5 | 6 | This program is free software; you can redistribute it and/or modify 7 | it under the terms of the GNU General Public License as published by 8 | the Free Software Foundation; either version 2 of the License, or 9 | (at your option) any later version. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU General Public License for more details. 15 | 16 | You should have received a copy of the GNU General Public License 17 | along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 19 | *) 20 | 21 | open Printf 22 | open Http_types 23 | 24 | let callback req outchan = 25 | let str = 26 | (sprintf "request path = %s\n" req#path) ^ 27 | (sprintf "request GET params = %s\n" 28 | (String.concat ";" 29 | (List.map (fun (h,v) -> String.concat "=" [h;v]) req#params_GET))) ^ 30 | (sprintf "request POST params = %s\n" 31 | (String.concat ";" 32 | (List.map (fun (h,v) -> String.concat "=" [h;v]) req#params_POST))) ^ 33 | (sprintf "request ALL params = %s\n" 34 | (String.concat ";" 35 | (List.map (fun (h,v) -> String.concat "=" [h;v]) req#params))) ^ 36 | (sprintf "cookies = %s\n" 37 | (match req#cookies with 38 | | None -> 39 | "NO COOKIES " 40 | ^ (if req#hasHeader ~name:"cookie" 41 | then "('Cookie:' header was '" ^ req#header ~name:"cookie" ^ "')" 42 | else "(No 'Cookie:' header received)") 43 | | Some cookies -> 44 | (String.concat ";" 45 | (List.map (fun (n,v) -> String.concat "=" [n;v]) cookies)))) ^ 46 | (sprintf "request BODY = '%s'\n\n" req#body) 47 | in 48 | Http_daemon.respond ~code:(`Code 200) ~body: str outchan 49 | 50 | let spec = 51 | { Http_daemon.default_spec with 52 | callback = callback; 53 | port = 9999; 54 | } 55 | 56 | let _ = Http_daemon.main spec 57 | 58 | -------------------------------------------------------------------------------- /examples/highlander.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2004> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU General Public License as published by 9 | the Free Software Foundation; either version 2 of the License, or 10 | (at your option) any later version. 11 | 12 | This program is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | GNU General Public License for more details. 16 | 17 | You should have received a copy of the GNU General Public License 18 | along with this program; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | (* test for fast rebinding of the tcp port *) 23 | 24 | open Printf 25 | open Http_types 26 | 27 | let spec = 28 | { Http_daemon.default_spec with 29 | callback = (fun _ outchan -> Http_daemon.respond ~body:"foo" outchan); 30 | port = 9999; 31 | mode = `Single; 32 | } 33 | 34 | let _ = 35 | Sys.catch_break true; 36 | while true do 37 | try 38 | Http_daemon.main spec; 39 | with Sys.Break -> prerr_endline "RESURRECTION!!!!" 40 | done 41 | 42 | -------------------------------------------------------------------------------- /examples/oo_daemon.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2004> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU General Public License as published by 9 | the Free Software Foundation; either version 2 of the License, or 10 | (at your option) any later version. 11 | 12 | This program is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | GNU General Public License for more details. 16 | 17 | You should have received a copy of the GNU General Public License 18 | along with this program; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | open Http_daemon 23 | open Http_response 24 | 25 | (* the simple way *) 26 | let d = new daemon ~addr:"127.0.0.1" ~port:9999 () 27 | 28 | let _ = 29 | while true do 30 | let (req, conn) = d#getRequest in (* wait for valid request *) 31 | conn#respond_with (new response ~body:"foo\n" ()); 32 | conn#close 33 | done 34 | 35 | (* 36 | (* the hard^Wother way *) 37 | let d = new daemon ~addr:"127.0.0.1" ~port:9999 () in 38 | let _ = 39 | while true do 40 | let conn = d#accept in (* wait for client connection *) 41 | (match conn#getRequest with 42 | | None -> () (* invalid request received *) 43 | | Some req -> conn#respond_with (new response ~body:"foo\n" ())); 44 | conn#close (* close socket *) 45 | done 46 | *) 47 | 48 | -------------------------------------------------------------------------------- /examples/threads.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2004> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU General Public License as published by 9 | the Free Software Foundation; either version 2 of the License, or 10 | (at your option) any later version. 11 | 12 | This program is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | GNU General Public License for more details. 16 | 17 | You should have received a copy of the GNU General Public License 18 | along with this program; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | open Http_types 23 | 24 | let m = Mutex.create () 25 | let m_locked = ref true 26 | 27 | let critical f = 28 | Mutex.lock m; 29 | m_locked := true; 30 | Lazy.force f; 31 | m_locked := false; 32 | Mutex.unlock m 33 | 34 | (** ocaml's Thread.unlock suspend the invoking process if the mutex is already 35 | * unlocked, therefore we unlock it only if we know that it's currently locked 36 | *) 37 | let safe_unlock _ _ = if !m_locked then Mutex.unlock m 38 | 39 | let i = ref 10 40 | let dump_i outchan = 41 | Http_daemon.respond ~body:(Printf.sprintf "i = %d\n" !i) outchan 42 | 43 | let callback req outchan = 44 | match req#path with 45 | | "/incr" -> critical (lazy (incr i; dump_i outchan; Unix.sleep 5)) 46 | | "/decr" -> critical (lazy (decr i; dump_i outchan; Unix.sleep 5)) 47 | | "/get" -> critical (lazy (dump_i outchan)) 48 | | bad_request -> Http_daemon.respond_error outchan 49 | 50 | let spec = 51 | { Http_daemon.default_spec with 52 | port = 9999; 53 | mode = `Thread; 54 | callback = callback; 55 | exn_handler = Some safe_unlock; 56 | (** ocaml-http's default exn_handler is Pervasives.ignore. This means 57 | * that threads holding the "m" mutex above may die without unlocking it. 58 | * Using safe_unlock as an exception handler we ensure that "m" mutex is 59 | * unlocked in case of exceptions (e.g. SIGPIPE) *) 60 | } 61 | 62 | let _ = Http_daemon.main spec 63 | 64 | -------------------------------------------------------------------------------- /examples/timeout.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2004> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU General Public License as published by 9 | the Free Software Foundation; either version 2 of the License, or 10 | (at your option) any later version. 11 | 12 | This program is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | GNU General Public License for more details. 16 | 17 | You should have received a copy of the GNU General Public License 18 | along with this program; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | open Http_types 23 | 24 | let spec = 25 | { Http_daemon.default_spec with 26 | callback = (fun _ outchan -> Http_daemon.respond ~body:"foo" outchan); 27 | timeout = Some 10; 28 | } 29 | 30 | let _ = Http_daemon.main spec 31 | 32 | -------------------------------------------------------------------------------- /examples/webfsd.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2004> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU General Public License as published by 9 | the Free Software Foundation; either version 2 of the License, or 10 | (at your option) any later version. 11 | 12 | This program is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | GNU General Public License for more details. 16 | 17 | You should have received a copy of the GNU General Public License 18 | along with this program; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | open Http_types 23 | 24 | let def_port = 80 25 | let def_addr = "0.0.0.0" 26 | let def_root = Sys.getcwd () 27 | 28 | let port = ref def_port 29 | let addr = ref def_addr 30 | let root = ref def_root 31 | let argspec = 32 | [ "-p", Arg.Int (fun p -> port := p), 33 | "TCP port on which listen, default: " ^ string_of_int !port; 34 | "-a", Arg.String (fun a -> addr := a), 35 | "IP address on which listen, default: " ^ !addr; 36 | "-r", Arg.String (fun r -> root := r), 37 | "DocumentRoot, default: current working directory"; 38 | ] 39 | 40 | let _ = 41 | Arg.parse argspec (fun _ -> ()) ""; 42 | let spec = 43 | { Http_daemon.default_spec with 44 | address = !addr; 45 | port = !port; 46 | root_dir = Some !root 47 | } 48 | in 49 | Http_daemon.Trivial.main spec 50 | 51 | -------------------------------------------------------------------------------- /http_common.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2005> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU Library General Public License as 9 | published by the Free Software Foundation, version 2. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU Library General Public License for more details. 15 | 16 | You should have received a copy of the GNU Library General Public 17 | License along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | open Http_types;; 23 | open Printf;; 24 | 25 | let debug = ref false 26 | let debug_print s = 27 | if !debug then 28 | prerr_endline (sprintf "[OCaml HTTP] DEBUG: %s" s) 29 | 30 | let http_version = Http_constants.version 31 | let server_string = Http_constants.server_string 32 | 33 | let string_of_version = function 34 | | `HTTP_1_0 -> "HTTP/1.0" 35 | | `HTTP_1_1 -> "HTTP/1.1" 36 | 37 | let version_of_string = function 38 | | "HTTP/1.0" -> `HTTP_1_0 39 | | "HTTP/1.1" -> `HTTP_1_1 40 | | invalid_version -> raise (Invalid_HTTP_version invalid_version) 41 | 42 | let string_of_method = function 43 | | `GET -> "GET" 44 | | `POST -> "POST" 45 | | `HEAD -> "HEAD" 46 | | `PUT -> "PUT" 47 | | `DELETE -> "DELETE" 48 | | `OPTIONS -> "OPTIONS" 49 | | `TRACE -> "TRACE" 50 | 51 | let method_of_string = function 52 | | "GET" -> `GET 53 | | "POST" -> `POST 54 | | "HEAD" -> `HEAD 55 | | "PUT" -> `PUT 56 | | "DELETE" -> `DELETE 57 | | "OPTIONS" -> `OPTIONS 58 | | "TRACE" -> `TRACE 59 | | invalid_method -> raise (Invalid_HTTP_method invalid_method) 60 | 61 | let string_of_request req = 62 | let buffer = Buffer.create 1024 in 63 | Buffer.add_string buffer (string_of_method req#meth); 64 | Buffer.add_char buffer ' '; 65 | Buffer.add_string buffer req#uri; 66 | Buffer.add_char buffer ' '; 67 | (match req#version with 68 | | Some v -> Buffer.add_string buffer (string_of_version v) 69 | | None -> ()); 70 | Buffer.add_string buffer "\r\n"; 71 | List.iter 72 | (fun (param_name, param_value) -> 73 | Buffer.add_string buffer param_name; 74 | Buffer.add_string buffer ": "; 75 | Buffer.add_string buffer param_value; 76 | Buffer.add_string buffer "\r\n"; 77 | ) 78 | req#headers; 79 | Buffer.add_string buffer "\r\n"; 80 | Buffer.add_string buffer req#body; 81 | Buffer.contents buffer 82 | 83 | let status_of_code = function 84 | | 100 -> `Informational `Continue 85 | | 101 -> `Informational `Switching_protocols 86 | | 200 -> `Success `OK 87 | | 201 -> `Success `Created 88 | | 202 -> `Success `Accepted 89 | | 203 -> `Success `Non_authoritative_information 90 | | 204 -> `Success `No_content 91 | | 205 -> `Success `Reset_content 92 | | 206 -> `Success `Partial_content 93 | | 300 -> `Redirection `Multiple_choices 94 | | 301 -> `Redirection `Moved_permanently 95 | | 302 -> `Redirection `Found 96 | | 303 -> `Redirection `See_other 97 | | 304 -> `Redirection `Not_modified 98 | | 305 -> `Redirection `Use_proxy 99 | | 307 -> `Redirection `Temporary_redirect 100 | | 400 -> `Client_error `Bad_request 101 | | 401 -> `Client_error `Unauthorized 102 | | 402 -> `Client_error `Payment_required 103 | | 403 -> `Client_error `Forbidden 104 | | 404 -> `Client_error `Not_found 105 | | 405 -> `Client_error `Method_not_allowed 106 | | 406 -> `Client_error `Not_acceptable 107 | | 407 -> `Client_error `Proxy_authentication_required 108 | | 408 -> `Client_error `Request_time_out 109 | | 409 -> `Client_error `Conflict 110 | | 410 -> `Client_error `Gone 111 | | 411 -> `Client_error `Length_required 112 | | 412 -> `Client_error `Precondition_failed 113 | | 413 -> `Client_error `Request_entity_too_large 114 | | 414 -> `Client_error `Request_URI_too_large 115 | | 415 -> `Client_error `Unsupported_media_type 116 | | 416 -> `Client_error `Requested_range_not_satisfiable 117 | | 417 -> `Client_error `Expectation_failed 118 | | 500 -> `Server_error `Internal_server_error 119 | | 501 -> `Server_error `Not_implemented 120 | | 502 -> `Server_error `Bad_gateway 121 | | 503 -> `Server_error `Service_unavailable 122 | | 504 -> `Server_error `Gateway_time_out 123 | | 505 -> `Server_error `HTTP_version_not_supported 124 | | invalid_code -> raise (Invalid_code invalid_code) 125 | 126 | let code_of_status = function 127 | | `Informational `Continue -> 100 128 | | `Informational `Switching_protocols -> 101 129 | | `Success `OK -> 200 130 | | `Success `Created -> 201 131 | | `Success `Accepted -> 202 132 | | `Success `Non_authoritative_information -> 203 133 | | `Success `No_content -> 204 134 | | `Success `Reset_content -> 205 135 | | `Success `Partial_content -> 206 136 | | `Redirection `Multiple_choices -> 300 137 | | `Redirection `Moved_permanently -> 301 138 | | `Redirection `Found -> 302 139 | | `Redirection `See_other -> 303 140 | | `Redirection `Not_modified -> 304 141 | | `Redirection `Use_proxy -> 305 142 | | `Redirection `Temporary_redirect -> 307 143 | | `Client_error `Bad_request -> 400 144 | | `Client_error `Unauthorized -> 401 145 | | `Client_error `Payment_required -> 402 146 | | `Client_error `Forbidden -> 403 147 | | `Client_error `Not_found -> 404 148 | | `Client_error `Method_not_allowed -> 405 149 | | `Client_error `Not_acceptable -> 406 150 | | `Client_error `Proxy_authentication_required -> 407 151 | | `Client_error `Request_time_out -> 408 152 | | `Client_error `Conflict -> 409 153 | | `Client_error `Gone -> 410 154 | | `Client_error `Length_required -> 411 155 | | `Client_error `Precondition_failed -> 412 156 | | `Client_error `Request_entity_too_large -> 413 157 | | `Client_error `Request_URI_too_large -> 414 158 | | `Client_error `Unsupported_media_type -> 415 159 | | `Client_error `Requested_range_not_satisfiable -> 416 160 | | `Client_error `Expectation_failed -> 417 161 | | `Server_error `Internal_server_error -> 500 162 | | `Server_error `Not_implemented -> 501 163 | | `Server_error `Bad_gateway -> 502 164 | | `Server_error `Service_unavailable -> 503 165 | | `Server_error `Gateway_time_out -> 504 166 | | `Server_error `HTTP_version_not_supported -> 505 167 | 168 | let is_informational code = 169 | match status_of_code code with 170 | | `Informational _ -> true 171 | | _ -> false 172 | 173 | let is_success code = 174 | match status_of_code code with 175 | | `Success _ -> true 176 | | _ -> false 177 | 178 | let is_redirection code = 179 | match status_of_code code with 180 | | `Redirection _ -> true 181 | | _ -> false 182 | 183 | let is_client_error code = 184 | match status_of_code code with 185 | | `Client_error _ -> true 186 | | _ -> false 187 | 188 | let is_server_error code = 189 | match status_of_code code with 190 | | `Server_error _ -> true 191 | | _ -> false 192 | 193 | let is_error code = is_client_error code || is_server_error code 194 | 195 | -------------------------------------------------------------------------------- /http_common.mli: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2005> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU Library General Public License as 9 | published by the Free Software Foundation, version 2. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU Library General Public License for more details. 15 | 16 | You should have received a copy of the GNU Library General Public 17 | License along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | (** Common functionalities shared by other OCaml HTTP modules *) 23 | 24 | open Http_types;; 25 | 26 | (** whether debugging messages are enabled or not, can be changed at runtime 27 | *) 28 | val debug: bool ref 29 | 30 | (** print a string on stderr only if debugging is enabled *) 31 | val debug_print: string -> unit 32 | 33 | (** see {!Http_constants.version} *) 34 | val http_version: version 35 | 36 | (** see {!Http_constants.server_string} *) 37 | val server_string: string 38 | 39 | (** pretty print an HTTP version *) 40 | val string_of_version: version -> string 41 | 42 | (** parse an HTTP version from a string 43 | @raise Invalid_HTTP_version if given string doesn't represent a supported HTTP 44 | version *) 45 | val version_of_string: string -> version 46 | 47 | (** pretty print an HTTP method *) 48 | val string_of_method: meth -> string 49 | 50 | (** parse an HTTP method from a string 51 | @raise Invalid_HTTP_method if given string doesn't represent a supported 52 | method *) 53 | val method_of_string: string -> meth 54 | 55 | (** pretty print an HTTP request *) 56 | val string_of_request: Http_types.request -> string 57 | 58 | (** converts an integer HTTP status to the corresponding status value 59 | @raise Invalid_code if given integer isn't a valid HTTP status code *) 60 | val status_of_code: int -> status 61 | 62 | (** converts an HTTP status to the corresponding integer value *) 63 | val code_of_status: [< status] -> int 64 | 65 | (** @return true on "informational" status codes, false elsewhere *) 66 | val is_informational: int -> bool 67 | 68 | (** @return true on "success" status codes, false elsewhere *) 69 | val is_success: int -> bool 70 | 71 | (** @return true on "redirection" status codes, false elsewhere *) 72 | val is_redirection: int -> bool 73 | 74 | (** @return true on "client error" status codes, false elsewhere *) 75 | val is_client_error: int -> bool 76 | 77 | (** @return true on "server error" status codes, false elsewhere *) 78 | val is_server_error: int -> bool 79 | 80 | (** @return true on "client error" and "server error" status code, false 81 | elsewhere *) 82 | val is_error: int -> bool 83 | 84 | -------------------------------------------------------------------------------- /http_constants.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2005> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU Library General Public License as 9 | published by the Free Software Foundation, version 2. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU Library General Public License for more details. 15 | 16 | You should have received a copy of the GNU Library General Public 17 | License along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | let version = `HTTP_1_1 ;; 23 | let server_string = "OCaml HTTP Daemon" ;; 24 | let crlf = "\r\n" ;; 25 | 26 | let default_addr = "0.0.0.0" 27 | let default_auth = None 28 | let default_auto_close = true 29 | let default_callback = fun _ _ -> () 30 | let default_mode = `Fork 31 | let default_port = 80 32 | let default_root_dir = None 33 | let default_exn_handler = Some (fun exn outchan -> ()) 34 | let default_timeout = Some 300 35 | 36 | 37 | -------------------------------------------------------------------------------- /http_constants.mli: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2005> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU Library General Public License as 9 | published by the Free Software Foundation, version 2. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU Library General Public License for more details. 15 | 16 | You should have received a copy of the GNU Library General Public 17 | License along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | (** Constants *) 23 | 24 | (** default HTTP version *) 25 | val version: Http_types.version 26 | 27 | (** string returned as value of "Server:" response header *) 28 | val server_string: string 29 | 30 | (** "\r\n" string *) 31 | val crlf: string 32 | 33 | (** {2 daemon default values} *) 34 | 35 | val default_addr: string 36 | val default_auth: (string * Http_types.auth_info) option 37 | val default_auto_close: bool 38 | val default_callback: Http_types.request -> out_channel -> unit 39 | val default_mode: Http_types.daemon_mode 40 | val default_port: int 41 | val default_root_dir: string option 42 | val default_exn_handler: (exn -> out_channel -> unit) option 43 | val default_timeout: int option 44 | 45 | -------------------------------------------------------------------------------- /http_daemon.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2005> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU Library General Public License as 9 | published by the Free Software Foundation, version 2. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU Library General Public License for more details. 15 | 16 | You should have received a copy of the GNU Library General Public 17 | License along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | open Printf 23 | 24 | open Http_common 25 | open Http_types 26 | open Http_constants 27 | open Http_parser 28 | 29 | exception Http_daemon_failure of string 30 | 31 | (** send raw data on outchan, flushing it afterwards *) 32 | let send_raw ~data outchan = 33 | output_string outchan data; 34 | flush outchan 35 | 36 | let send_CRLF = send_raw ~data:crlf 37 | 38 | let send_header ~header ~value = 39 | let header = String.lowercase_ascii header in 40 | Http_parser_sanity.heal_header (header, value); 41 | send_raw ~data:(header ^ ": " ^ value ^ crlf) 42 | 43 | let send_headers ~headers outchan = 44 | List.iter (fun (header, value) -> send_header ~header ~value outchan) headers 45 | 46 | (** internal: low level for send_status_line *) 47 | let send_status_line' ~version code = 48 | let status_line = 49 | String.concat 50 | " " 51 | [ string_of_version version; 52 | string_of_int code; 53 | Http_misc.reason_phrase_of_code code ] 54 | in 55 | send_raw ~data:(status_line ^ crlf) 56 | 57 | let int_of_code = function 58 | | `Code code -> code 59 | | `Status status -> code_of_status status 60 | 61 | let send_status_line ?(version = http_version) ~(code: status_code) outchan = 62 | send_status_line' ~version (int_of_code code) outchan 63 | 64 | let get_basic_headers () = 65 | ["Date", Http_misc.date_822 (); 66 | "Server", server_string; 67 | "Connection", "close"] 68 | 69 | let send_basic_headers ?(version = http_version) ~(code: status_code) outchan = 70 | send_status_line' ~version (int_of_code code) outchan; 71 | send_headers ~headers:(get_basic_headers ()) outchan 72 | 73 | (** internal: given a status code and an additional body return a string 74 | representing an HTML document that explains the meaning of given status code. 75 | Additional data can be added to the body via 'body' argument *) 76 | let foo_body code body = 77 | let reason_phrase = Http_misc.reason_phrase_of_code code in 78 | sprintf 79 | " 80 | 81 | %d %s 82 | 83 |

%d - %s

%s 84 | " 85 | code reason_phrase code reason_phrase body 86 | 87 | (** internal: send a fooish body explaining in HTML form the 'reason phrase' 88 | of an HTTP response; body, if given, will be appended to the body *) 89 | let send_foo_body code body = send_raw ~data:(foo_body code body) 90 | 91 | (* Warning: keep default values in sync with Http_response.response class *) 92 | let respond_head ?content_length ?(headers = []) ?version ?(code = `Code 200) outchan = 93 | send_basic_headers ?version ~code outchan; 94 | send_headers ~headers outchan; 95 | (match content_length with 96 | | None -> () 97 | | Some amount -> send_header "Content-Length" (string_of_int amount) outchan); 98 | send_CRLF outchan 99 | 100 | (* Warning: keep default values in sync with Http_response.response class *) 101 | let respond ?(body = "") ?(headers = []) ?version ?(code = `Code 200) outchan = 102 | send_basic_headers ?version ~code outchan; 103 | send_headers ~headers outchan; 104 | send_header "Content-Length" (string_of_int (String.length body)) outchan; 105 | send_CRLF outchan; 106 | send_raw ~data:body outchan 107 | 108 | let respond_trace ?req ?(headers = []) ?version ?(code = `Code 200) outchan = 109 | let body = match req with 110 | | Some r -> string_of_request r 111 | | None -> "" 112 | in 113 | respond ~body ~headers ?version ~code outchan 114 | 115 | (** internal: low level for respond_redirect, respond_error, ... 116 | This function send a status line corresponding to a given code, some basic 117 | headers, the additional headers (if given) and an HTML page containing the 118 | reason phrase; if body is given it will be included in the body of the HTML 119 | page *) 120 | let send_empty_response 121 | func_name ?(is_valid_status = fun _ -> true) ?(headers=[]) ?(body="") () = 122 | fun ?version code outchan -> 123 | if not (is_valid_status (int_of_code code)) then 124 | failwith 125 | (sprintf "'%d' isn't a valid status code for %s" 126 | (int_of_code code) func_name) 127 | else begin (* status code suitable for answering *) 128 | let headers = 129 | [ "Content-Type", "text/html; charset=iso-8859-1" ] @ headers 130 | in 131 | let body = (foo_body (int_of_code code) body) ^ body in 132 | respond ?version ~code ~headers ~body outchan 133 | end 134 | 135 | let respond_redirect 136 | ~location ?body ?version ?(code = `Code 301) outchan 137 | = 138 | send_empty_response "Daemon.respond_redirect" ~is_valid_status:is_redirection 139 | ~headers:["Location", location] ?body () ?version code outchan 140 | 141 | let respond_error ?body ?version ?(code = `Code 400) outchan = 142 | send_empty_response "Daemon.respond_error" ~is_valid_status:is_error 143 | ?body () ?version code outchan 144 | 145 | let respond_not_found ~url ?version outchan = 146 | send_empty_response "Daemon.respond_not_found" () ?version (`Code 404) outchan 147 | 148 | let respond_forbidden ~url ?version outchan = 149 | send_empty_response "Daemon.respond_permission_denied" () ?version 150 | (`Code 403) outchan 151 | 152 | let respond_unauthorized ?version ?(realm = server_string) outchan = 153 | let body = 154 | sprintf "401 - Unauthorized - Authentication failed for realm \"%s\"" realm 155 | in 156 | respond ~headers:["WWW-Authenticate", sprintf "Basic realm=\"%s\"" realm] 157 | ~code:(`Code 401) ~body outchan 158 | 159 | let send_file ~src outchan = 160 | let buflen = 1024 in 161 | let buf = Bytes.make buflen ' ' in 162 | 163 | let (file, cleanup) = 164 | match src with 165 | | FileSrc fname -> (* if we open the file, we close it before returning *) 166 | let f = open_in fname in 167 | f, (fun () -> close_in f) 168 | | InChanSrc inchan -> inchan, ignore 169 | in 170 | try 171 | while true do 172 | let bytes = input file buf 0 buflen in 173 | if bytes = 0 then 174 | raise End_of_file 175 | else 176 | output outchan buf 0 bytes 177 | done; 178 | assert false 179 | with End_of_file -> 180 | begin 181 | flush outchan; 182 | cleanup () 183 | end 184 | 185 | (* TODO interface is too ugly to advertise this function in .mli *) 186 | (** create a minimal HTML directory listing of a given directory and send it 187 | over an out_channel, directory is passed as a dir_handle; name is the 188 | directory name, used for pretty printing purposes; path is the opened dir 189 | path, used to test its contents with stat *) 190 | let send_dir_listing ~dir ~name ~path outchan = 191 | fprintf outchan "\n%s\n\n" name; 192 | let (dirs, files) = 193 | List.partition (fun e -> Http_misc.is_directory (path ^ e)) (Http_misc.ls dir) 194 | in 195 | List.iter 196 | (fun d -> fprintf outchan "%s/
\n" d d) 197 | (List.sort compare dirs); 198 | List.iter 199 | (fun f -> fprintf outchan "%s
\n" f f) 200 | (List.sort compare files); 201 | fprintf outchan "\n"; 202 | flush outchan 203 | 204 | let respond_file ~fname ?(version = http_version) outchan = 205 | (** ASSUMPTION: 'fname' doesn't begin with a "/"; it's relative to the current 206 | document root (usually the daemon's cwd) *) 207 | let droot = Sys.getcwd () in (* document root *) 208 | let path = droot ^ "/" ^ fname in (* full path to the desired file *) 209 | if not (Sys.file_exists path) then (* file not found *) 210 | respond_not_found ~url:fname outchan 211 | else begin 212 | try 213 | if Http_misc.is_directory path then begin (* file found, is a dir *) 214 | let dir = Unix.opendir path in 215 | send_basic_headers ~version ~code:(`Code 200) outchan; 216 | send_header "Content-Type" "text/html" outchan; 217 | send_CRLF outchan; 218 | send_dir_listing ~dir ~name:fname ~path outchan; 219 | Unix.closedir dir 220 | end else begin (* file found, is something else *) 221 | let file = open_in fname in 222 | send_basic_headers ~version ~code:(`Code 200) outchan; 223 | send_header 224 | ~header:"Content-Length" 225 | ~value:(string_of_int (Http_misc.filesize fname)) 226 | outchan; 227 | send_CRLF outchan; 228 | send_file ~src:(InChanSrc file) outchan; 229 | close_in file 230 | end 231 | with 232 | | Unix.Unix_error (Unix.EACCES, _, _) 233 | | Sys_error _ -> 234 | respond_forbidden ~url:fname ~version outchan 235 | end 236 | 237 | let respond_with (res: Http_types.response) outchan = 238 | res#serialize outchan; 239 | flush outchan 240 | 241 | (** internal: this exception is raised after a malformed request has been read 242 | by a serving process to signal main server (or itself if mode = `Single) to 243 | skip to next request *) 244 | exception Again;; 245 | 246 | let pp_parse_exc e = 247 | sprintf "HTTP request parse error: %s" (Printexc.to_string e) 248 | 249 | (* given a Http_parser.parse_request like function, wrap it in a function that 250 | do the same and additionally catch parsing exception sending HTTP error 251 | messages back to client as needed. Returned function raises Again when it 252 | encounter a parse error (name 'Again' is intended for future versions that 253 | will support http keep alive signaling that a new request has to be parsed 254 | from client) *) 255 | let rec wrap_parse_request_w_safety parse_function inchan outchan = 256 | (try 257 | parse_function inchan 258 | with 259 | | (Malformed_request req) as e -> 260 | debug_print (pp_parse_exc e); 261 | respond_error ~code:(`Code 400) 262 | ~body:("request 1st line format should be: " ^ 263 | "'<method> <url> <version>'" ^ 264 | "
\nwhile received request 1st line was:
\n" ^ req) 265 | outchan; 266 | raise Again 267 | | (Invalid_HTTP_method meth) as e -> 268 | debug_print (pp_parse_exc e); 269 | respond_error ~code:(`Code 501) 270 | ~body:("Method '" ^ meth ^ "' isn't supported (yet)") 271 | outchan; 272 | raise Again 273 | | (Malformed_request_URI uri) as e -> 274 | debug_print (pp_parse_exc e); 275 | respond_error ~code:(`Code 400) ~body:("Malformed URL: '" ^ uri ^ "'") 276 | outchan; 277 | raise Again 278 | | (Invalid_HTTP_version version) as e -> 279 | debug_print (pp_parse_exc e); 280 | respond_error ~code:(`Code 505) 281 | ~body:("HTTP version '" ^ version ^ "' isn't supported (yet)") 282 | outchan; 283 | raise Again 284 | | (Malformed_query query) as e -> 285 | debug_print (pp_parse_exc e); 286 | respond_error ~code:(`Code 400) 287 | ~body:(sprintf "Malformed query string '%s'" query) outchan; 288 | raise Again 289 | | (Malformed_query_part (binding, query)) as e -> 290 | debug_print (pp_parse_exc e); 291 | respond_error ~code:(`Code 400) 292 | ~body:(sprintf "Malformed query part '%s' in query '%s'" binding query) 293 | outchan; 294 | raise Again) 295 | 296 | (* wrapper around Http_parser.parse_request which catch parsing exceptions and 297 | return error messages to client as needed 298 | @param inchan in_channel from which read incoming requests 299 | @param outchan out_channl on which respond with error messages if needed 300 | *) 301 | let safe_parse_request = wrap_parse_request_w_safety parse_request 302 | 303 | (* as above but for OO version (Http_parser.parse_request') *) 304 | let safe_parse_request' = wrap_parse_request_w_safety (new Http_request.request) 305 | 306 | let chdir_to_document_root = function (* chdir to document root *) 307 | | Some dir -> Sys.chdir dir 308 | | None -> () 309 | 310 | let server_of_mode = function 311 | | `Single -> Http_tcp_server.simple 312 | | `Fork -> Http_tcp_server.fork 313 | | `Thread -> Http_tcp_server.thread 314 | 315 | (* TODO what happens when a Quit exception is raised by a callback? Do other 316 | callbacks keep on living until the end or are them all killed immediatly? 317 | The right semantics should obviously be the first one *) 318 | 319 | (** - handle HTTP authentication 320 | * - handle automatic closures of client connections *) 321 | let invoke_callback req spec outchan = 322 | let callback req outchan = 323 | if spec.auto_close then 324 | Http_misc.finally 325 | (fun () -> try close_out outchan with Sys_error _ -> ()) 326 | (fun () -> spec.callback req outchan) () 327 | else 328 | spec.callback req outchan in 329 | try 330 | (match (spec.auth, req#authorization) with 331 | | None, _ -> callback req outchan (* no auth required *) 332 | | Some (realm, `Basic (spec_username, spec_password)), 333 | Some (`Basic (username, password)) 334 | when (username = spec_username) && (password = spec_password) -> 335 | (* auth ok *) 336 | callback req outchan 337 | | Some (realm, _), _ -> raise (Unauthorized realm)) (* auth failure *) 338 | with 339 | | Unauthorized realm -> respond_unauthorized ~realm outchan 340 | | Again -> () 341 | 342 | let main spec = 343 | chdir_to_document_root spec.root_dir; 344 | let sockaddr = Http_misc.build_sockaddr (spec.address, spec.port) in 345 | let daemon_callback inchan outchan = 346 | let next_req () = 347 | try Some (safe_parse_request' inchan outchan) 348 | with _ -> None 349 | in 350 | let rec loop n = 351 | match next_req () with 352 | | Some req -> 353 | debug_print (sprintf "request #%d" n); 354 | invoke_callback req spec outchan; 355 | flush outchan; 356 | loop (n + 1) 357 | | None -> 358 | debug_print "server exiting"; 359 | () 360 | in 361 | debug_print "server starting"; 362 | try loop 1 363 | with exn -> 364 | debug_print (sprintf "uncaught exception: %s" (Printexc.to_string exn)); 365 | (match spec.exn_handler with 366 | | Some f -> 367 | debug_print "executing handler"; 368 | f exn outchan 369 | | None -> 370 | debug_print "no handler given: re-raising"; 371 | raise exn) 372 | in 373 | try 374 | (server_of_mode spec.mode) ~sockaddr ~timeout:spec.timeout daemon_callback 375 | with Quit -> () 376 | 377 | module Trivial = 378 | struct 379 | let heading_slash_RE = Pcre.regexp "^/" 380 | 381 | let trivial_callback req outchan = 382 | let path = req#path in 383 | if not (Pcre.pmatch ~rex:heading_slash_RE path) then 384 | respond_error ~code:(`Code 400) outchan 385 | else 386 | respond_file ~fname:(Http_misc.strip_heading_slash path) outchan 387 | 388 | let callback = trivial_callback 389 | 390 | let main spec = main { spec with callback = trivial_callback } 391 | end 392 | 393 | (** @param inchan input channel connected to client 394 | @param outchan output channel connected to client 395 | @param sockaddr client socket address *) 396 | class connection inchan outchan sockaddr = 397 | (* ASSUMPTION: inchan and outchan are channels built on top of the same 398 | Unix.file_descr thus closing one of them will close also the other *) 399 | let close' o = try o#close with Http_daemon_failure _ -> () in 400 | object (self) 401 | 402 | initializer Gc.finalise close' self 403 | 404 | val mutable closed = false 405 | 406 | method private assertNotClosed = 407 | if closed then 408 | raise (Http_daemon_failure 409 | "Http_daemon.connection: connection is closed") 410 | 411 | method getRequest = 412 | self#assertNotClosed; 413 | try 414 | Some (safe_parse_request' inchan outchan) 415 | with _ -> None 416 | 417 | method respond_with res = 418 | self#assertNotClosed; 419 | respond_with res outchan 420 | 421 | method close = 422 | self#assertNotClosed; 423 | close_in inchan; (* this close also outchan *) 424 | closed <- true 425 | 426 | end 427 | 428 | class daemon ?(addr = "0.0.0.0") ?(port = 80) () = 429 | object (self) 430 | 431 | val suck = 432 | Http_tcp_server.init_socket (Http_misc.build_sockaddr (addr, port)) 433 | 434 | method accept = 435 | let (cli_suck, cli_sockaddr) = Unix.accept suck in (* may block *) 436 | let (inchan, outchan) = 437 | (Unix.in_channel_of_descr cli_suck, Unix.out_channel_of_descr cli_suck) 438 | in 439 | new connection inchan outchan cli_sockaddr 440 | 441 | method getRequest = 442 | let conn = self#accept in 443 | match conn#getRequest with 444 | | None -> 445 | conn#close; 446 | self#getRequest 447 | | Some req -> (req, conn) 448 | 449 | end 450 | 451 | open Http_constants 452 | 453 | let default_spec = { 454 | address = default_addr; 455 | auth = default_auth; 456 | auto_close = default_auto_close; 457 | callback = default_callback; 458 | mode = default_mode; 459 | port = default_port; 460 | root_dir = default_root_dir; 461 | exn_handler = default_exn_handler; 462 | timeout = default_timeout; 463 | } 464 | 465 | let daemon_spec 466 | ?(address = default_addr) ?(auth = default_auth) 467 | ?(auto_close = default_auto_close) 468 | ?(callback = default_callback) ?(mode = default_mode) ?(port = default_port) 469 | ?(root_dir = default_root_dir) ?(exn_handler = default_exn_handler) 470 | ?(timeout = default_timeout) 471 | () 472 | = 473 | { 474 | address = address; 475 | auth = auth; 476 | auto_close = auto_close; 477 | callback = callback; 478 | mode = mode; 479 | port = port; 480 | root_dir = root_dir; 481 | exn_handler = exn_handler; 482 | timeout = timeout; 483 | } 484 | 485 | -------------------------------------------------------------------------------- /http_daemon.mli: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2005> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU Library General Public License as 9 | published by the Free Software Foundation, version 2. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU Library General Public License for more details. 15 | 16 | You should have received a copy of the GNU Library General Public 17 | License along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | (** Main OCaml HTTP module. 23 | Here you can find two set of functions: 24 | - functions which let you start an HTTP Daemon (start* functions) 25 | - facility functions which let you sent responses back to clients *) 26 | 27 | (** send a CRLF sequence on the given output channel, this is mandatory after 28 | the last header was sent and before start sending the response body *) 29 | val send_CRLF: out_channel -> unit 30 | 31 | (** send response status line, version is the http version used in response, 32 | either code or status must be given (not both, not none) which represent the 33 | HTTP response code, outchan is the output channel to which send status line *) 34 | val send_status_line: 35 | ?version:Http_types.version -> code:Http_types.status_code -> 36 | out_channel -> 37 | unit 38 | 39 | (** returns the basic headers "Date", "Server" and "Connection" used in 40 | send_basic_headers *) 41 | val get_basic_headers: unit -> (string * string) list 42 | 43 | (** like send_status_line but additionally will also send "Date", "Server" 44 | and "Connection" standard headers *) 45 | val send_basic_headers: 46 | ?version: Http_types.version -> code:Http_types.status_code -> 47 | out_channel -> 48 | unit 49 | 50 | (** send an HTTP header on outchan *) 51 | val send_header: header: string -> value: string -> out_channel -> unit 52 | 53 | (** as send_header, but for a list of pairs *) 54 | val send_headers: headers:(string * string) list -> out_channel -> unit 55 | 56 | (* 57 | (** send a file through an out_channel, file can be passed as an in_channel 58 | (if 'file' is given) or as a file name (if 'name' is given) *) 59 | val send_file: ?name:string -> ?file:in_channel -> out_channel -> unit 60 | *) 61 | (** send a file through an out_channel *) 62 | val send_file: src:Http_types.file_source -> out_channel -> unit 63 | 64 | (** high level response function, specific to HEAD responses, 65 | respond on outchan sending: basic headers, headers provided 66 | via 'headers' argument, Content-length if provided. Default response 67 | status is 200, default response HTTP version is Http_common.http_version *) 68 | val respond_head: 69 | ?content_length:int -> ?headers:(string * string) list -> 70 | ?version:Http_types.version -> ?code:Http_types.status_code -> 71 | out_channel -> 72 | unit 73 | 74 | (** high level response function, respond on outchan sending: basic headers 75 | (including Content-Length computed using 'body' argument), headers probided 76 | via 'headers' argument, body given via 'body' argument. Default response 77 | status is 200, default response HTTP version is Http_common.http_version *) 78 | val respond: 79 | ?body:string -> ?headers:(string * string) list -> 80 | ?version:Http_types.version -> ?code:Http_types.status_code -> 81 | out_channel -> 82 | unit 83 | 84 | (** high level response function, specific to TRACE responses, 85 | respond on outchan sending: basic headers, headers provided 86 | via 'headers' argument, body given via 'req' argument. The 87 | supplied request will be sent back to the client. Default response 88 | status is 200, default response HTTP version is Http_common.http_version *) 89 | val respond_trace: 90 | ?req:Http_types.request -> 91 | ?headers:(string * string) list -> 92 | ?version:Http_types.version -> ?code:Http_types.status_code -> 93 | out_channel -> 94 | unit 95 | 96 | (** send a 404 (not found) HTTP response *) 97 | val respond_not_found: 98 | url:string -> ?version: Http_types.version -> out_channel -> unit 99 | 100 | (** send a 403 (forbidden) HTTP response *) 101 | val respond_forbidden: 102 | url:string -> ?version: Http_types.version -> out_channel -> unit 103 | 104 | (** send a "redirection" class response, optional body argument contains data 105 | that will be displayed in the body of the response, default response status is 106 | 301 (moved permanently), only redirection status are accepted by this 107 | function, other values will raise Failure *) 108 | val respond_redirect: 109 | location:string -> ?body:string -> 110 | ?version: Http_types.version -> ?code:Http_types.status_code -> 111 | out_channel -> 112 | unit 113 | 114 | (** respond with a 401 (Unauthorized) response asking for authentication 115 | * against given realm (default is the server name) *) 116 | val respond_unauthorized: 117 | ?version: Http_types.version -> ?realm:string -> out_channel -> unit 118 | 119 | (** send an "error" response (i.e. 400 <= status < 600), optional body 120 | argument as per send_redirect, default response status is 400 (bad request), 121 | only error status are accepted by this function, other values will 122 | raise Failure *) 123 | val respond_error: 124 | ?body:string -> 125 | ?version: Http_types.version -> ?code:Http_types.status_code -> 126 | out_channel -> 127 | unit 128 | 129 | (** tipical static pages http daemon behaviour, if requested url is a file, 130 | return it, it it is a directory return a directory listing of it *) 131 | val respond_file: 132 | fname:string -> ?version: Http_types.version -> out_channel -> unit 133 | 134 | (** respond using a prebuilt Http_types.response object *) 135 | val respond_with: Http_types.response -> out_channel -> unit 136 | 137 | (** start an HTTP daemon 138 | * @param spec specification of daemon behaviour 139 | *) 140 | val main: Http_types.daemon_spec -> unit 141 | 142 | (** default daemon specification: 143 | * - listen on 0.0.0.0, port 80 144 | * - "always ok" callback (return an empty response, response code 200) 145 | * - fork a child for each request 146 | * - do not change to a root directory (i.e. keep cwd) 147 | * - 300 seconds timeout 148 | * - ignores exceptions 149 | * - no authentication required 150 | * - do not automatically close client connections after callback *) 151 | val default_spec: Http_types.daemon_spec 152 | 153 | (** currified daemon_spec constructor. Each parameter of this function 154 | * corresponds to one field of Http_types.daemon_spec and defaults to the 155 | * corresponding field of Http_daemon.default_spec *) 156 | val daemon_spec: 157 | ?address:string -> 158 | ?auth:(string * Http_types.auth_info) option -> 159 | ?auto_close:bool -> 160 | ?callback:(Http_types.request -> out_channel -> unit) -> 161 | ?mode:(Http_types.daemon_mode) -> 162 | ?port:int -> 163 | ?root_dir:string option -> 164 | ?exn_handler:(exn -> out_channel -> unit) option -> 165 | ?timeout:int option -> 166 | unit -> 167 | Http_types.daemon_spec 168 | 169 | (* 170 | (** XXX 171 | * This function has been deprecated for a while. Now it has been removed! *) 172 | val start: 173 | ?addr: string -> ?port: int -> 174 | ?timeout: int option -> ?mode: Http_types.daemon_mode -> ?root: string -> 175 | (string -> (string * string) list -> out_channel -> unit) -> 176 | unit 177 | *) 178 | 179 | (* 180 | (** XXX 181 | * This function has been deprecated for a while. Now it has been removed! *) 182 | val start': 183 | ?addr: string -> ?port: int -> 184 | ?timeout: int option -> ?mode: Http_types.daemon_mode -> ?root: string -> 185 | (Http_types.request -> out_channel -> unit) -> 186 | unit 187 | *) 188 | 189 | (** Object oriented interface to HTTP daemons. 190 | * @param addr address on which daemon will listen for connections 191 | * @param port port which daemon will bind 192 | * see {!Http_types.daemon} *) 193 | class daemon: 194 | ?addr: string -> ?port: int -> 195 | unit -> 196 | Http_types.daemon 197 | 198 | (** Trivial static pages HTTP daemon. 199 | * Daemons created using this module will serve directory indexes and files 200 | * found starting from the working directory *) 201 | module Trivial : 202 | sig 203 | (** callback function, exposed if you like to use it as a basis to define 204 | a more powerful daemon *) 205 | val callback : Http_types.request -> out_channel -> unit 206 | 207 | (** start the "trivial" HTTP daemon 208 | * @param spec trivial HTTP daemon specification, "callback" field is 209 | * ignored and set to the callback above *) 210 | val main : Http_types.daemon_spec -> unit 211 | end 212 | 213 | -------------------------------------------------------------------------------- /http_message.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2005> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU Library General Public License as 9 | published by the Free Software Foundation, version 2. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU Library General Public License for more details. 15 | 16 | You should have received a copy of the GNU Library General Public 17 | License along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | open Http_common;; 23 | open Http_constants;; 24 | open Http_types;; 25 | open Printf;; 26 | 27 | (* remove all bindings of 'name' from hashtbl 'tbl' *) 28 | let rec hashtbl_remove_all tbl name = 29 | if not (Hashtbl.mem tbl name) then 30 | raise (Header_not_found name); 31 | Hashtbl.remove tbl name; 32 | if Hashtbl.mem tbl name then hashtbl_remove_all tbl name 33 | ;; 34 | 35 | class virtual message ~body ~headers ~version ~clisockaddr ~srvsockaddr = 36 | 37 | let ((cliaddr, cliport), (srvaddr, srvport)) = 38 | (Http_misc.explode_sockaddr clisockaddr, 39 | Http_misc.explode_sockaddr srvsockaddr) 40 | in 41 | 42 | object (self) 43 | 44 | val _contentsBuf = Buffer.create 1024 45 | val _headers = Hashtbl.create 11 46 | val mutable _version: version option = version 47 | 48 | initializer 49 | self#setBody body; 50 | self#addHeaders headers 51 | 52 | method version = _version 53 | method setVersion v = _version <- Some v 54 | 55 | method body = Buffer.contents _contentsBuf 56 | method setBody c = 57 | Buffer.clear _contentsBuf; 58 | Buffer.add_string _contentsBuf c 59 | method bodyBuf = _contentsBuf 60 | method setBodyBuf b = 61 | Buffer.clear _contentsBuf; 62 | Buffer.add_buffer _contentsBuf b 63 | method addBody s = Buffer.add_string _contentsBuf s 64 | method addBodyBuf b = Buffer.add_buffer _contentsBuf b 65 | 66 | method addHeader ~name ~value = 67 | let name = String.lowercase_ascii name in 68 | Http_parser_sanity.heal_header (name, value); 69 | Hashtbl.add _headers name value 70 | method addHeaders = 71 | List.iter (fun (name, value) -> self#addHeader ~name ~value) 72 | method replaceHeader ~name ~value = 73 | let name = String.lowercase_ascii name in 74 | Http_parser_sanity.heal_header (name, value); 75 | Hashtbl.replace _headers name value 76 | method replaceHeaders = 77 | List.iter (fun (name, value) -> self#replaceHeader ~name ~value) 78 | method removeHeader ~name = 79 | let name = String.lowercase_ascii name in 80 | hashtbl_remove_all _headers name 81 | method hasHeader ~name = 82 | let name = String.lowercase_ascii name in 83 | Hashtbl.mem _headers name 84 | method header ~name = 85 | if not (self#hasHeader name) then raise (Header_not_found name); 86 | let name = String.lowercase_ascii name in 87 | String.concat ", " (List.rev (Hashtbl.find_all _headers name)) 88 | method headers = 89 | List.rev 90 | (Hashtbl.fold 91 | (fun name _ headers -> (name, self#header ~name)::headers) 92 | _headers 93 | []) 94 | 95 | method clientSockaddr = clisockaddr 96 | method clientAddr = cliaddr 97 | method clientPort = cliport 98 | 99 | method serverSockaddr = srvsockaddr 100 | method serverAddr = srvaddr 101 | method serverPort = srvport 102 | 103 | method private virtual fstLineToString: string 104 | method toString = 105 | self#fstLineToString ^ (* {request,status} line *) 106 | crlf ^ 107 | (String.concat (* headers, crlf terminated *) 108 | "" 109 | (List.map (fun (h,v) -> h ^ ": " ^ v ^ crlf) self#headers)) ^ 110 | (sprintf "Content-Length: %d" (String.length self#body)) ^ crlf ^ 111 | crlf ^ 112 | self#body (* body *) 113 | method serialize outchan = 114 | output_string outchan self#toString; 115 | flush outchan 116 | 117 | end 118 | 119 | -------------------------------------------------------------------------------- /http_message.mli: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2005> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU Library General Public License as 9 | published by the Free Software Foundation, version 2. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU Library General Public License for more details. 15 | 16 | You should have received a copy of the GNU Library General Public 17 | License along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | (** Object Oriented representation of HTTP messages *) 23 | 24 | open Http_types;; 25 | 26 | (** OO representation of an HTTP message 27 | @param entity body included in the message 28 | @param headers message headers shipped with the message *) 29 | class virtual message: 30 | body: string -> headers: (string * string) list -> version: version option -> 31 | clisockaddr: Unix.sockaddr -> srvsockaddr: Unix.sockaddr -> 32 | object 33 | 34 | (** @return message HTTP version, it can be None because older version 35 | of the HTTP protocol don't require HTTP version to be told between 36 | message source and destination *) 37 | method version: version option 38 | 39 | (** set message HTTP version *) 40 | method setVersion: version -> unit 41 | 42 | (** @return message body *) 43 | method body: string 44 | 45 | (** set message body *) 46 | method setBody: string -> unit 47 | 48 | (** @return a Buffer.t connected to message body (Warning: changing this 49 | buffer will change message body too) *) 50 | method bodyBuf: Buffer.t 51 | 52 | (** set a new Buffer.t used to keep message body *) 53 | method setBodyBuf: Buffer.t -> unit 54 | 55 | (** append a string to message body *) 56 | method addBody: string -> unit 57 | 58 | (** append a whole buffer to message body *) 59 | method addBodyBuf: Buffer.t -> unit 60 | 61 | (** {i header name comparison are performed in a case-insensitive manner 62 | as required by RFC2616, actually the implementation works converting all 63 | header names in lowercase} *) 64 | 65 | (** add an HTTP header 66 | @param name header's name 67 | @param value header's value *) 68 | method addHeader: name:string -> value:string -> unit 69 | 70 | (** add a list of HTTP headers 71 | @param headers a list of pairs: header_name, header_value *) 72 | method addHeaders: (string * string) list -> unit 73 | 74 | (** like addHeader but replace previous definition of the same header *) 75 | method replaceHeader: name:string -> value:string -> unit 76 | 77 | (** like addHeaders but replace previous definition of headers that were 78 | already defined *) 79 | method replaceHeaders: (string * string) list -> unit 80 | 81 | (** remove _all_ occurences of an HTTP header from the message 82 | @param name name of the header to be removed *) 83 | method removeHeader: name:string -> unit 84 | 85 | (** @return true if given header exists in message, false otherwise *) 86 | method hasHeader: name:string -> bool 87 | 88 | (** @return value associated to a given header 89 | @param name name of the header to lookup 90 | @raise Header_not_found if given header wasn't defined in message *) 91 | method header: name:string -> string 92 | 93 | (** @return the full set of headers defined for this message, the value 94 | returned is an association list from headers name to headers value, an 95 | header may occurs more that once in the list *) 96 | method headers: (string * string) list 97 | 98 | 99 | (** @return client Unix.sockaddr *) 100 | method clientSockaddr: Unix.sockaddr 101 | 102 | (** @return client address pretty printed *) 103 | method clientAddr: string 104 | 105 | (** @return client port *) 106 | method clientPort: int 107 | 108 | (** @return server Unix.sockaddr *) 109 | method serverSockaddr: Unix.sockaddr 110 | 111 | (** @return server address pretty printed *) 112 | method serverAddr: string 113 | 114 | (** @return server port *) 115 | method serverPort: int 116 | 117 | 118 | (** @return for requests first request line, for responses first 119 | response line. 120 | User by derived requests and responses to implement toString method *) 121 | method private virtual fstLineToString: string 122 | 123 | (** @return a string representation of the message *) 124 | method toString: string 125 | 126 | (** serialize the message over an output channel *) 127 | method serialize: out_channel -> unit 128 | 129 | end 130 | 131 | -------------------------------------------------------------------------------- /http_misc.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2005> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU Library General Public License as 9 | published by the Free Software Foundation, version 2. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU Library General Public License for more details. 15 | 16 | You should have received a copy of the GNU Library General Public 17 | License along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | open Printf 23 | 24 | open Http_types 25 | 26 | let date_822 () = 27 | Netdate.mk_mail_date ~zone:Netdate.localzone (Unix.time ()) 28 | 29 | let is_directory name = 30 | match Unix.lstat name with 31 | | { Unix.st_kind = Unix.S_DIR } -> true 32 | | _ -> false 33 | 34 | let filesize fname = (Unix.stat fname).Unix.st_size 35 | 36 | let strip_trailing_slash = 37 | let rex = Pcre.regexp "/$" in 38 | fun s -> Pcre.replace ~rex ~templ:"" s 39 | 40 | let strip_heading_slash = 41 | let rex = Pcre.regexp "^/" in 42 | fun s -> Pcre.replace ~rex ~templ:"" s 43 | 44 | let ls dir = 45 | let rec ls' entries = 46 | try ls' ((Unix.readdir dir)::entries) with End_of_file -> entries 47 | in 48 | ls' [] 49 | 50 | let string_explode s = 51 | let rec string_explode' acc = function 52 | | "" -> acc 53 | | s -> string_explode' (s.[0] :: acc) (String.sub s 1 (String.length s - 1)) 54 | in 55 | List.rev (string_explode' [] s) 56 | 57 | let string_implode = List.fold_left (fun s c -> s ^ (String.make 1 c)) "" 58 | 59 | let reason_phrase_of_code = function 60 | | 100 -> "Continue" 61 | | 101 -> "Switching protocols" 62 | | 200 -> "OK" 63 | | 201 -> "Created" 64 | | 202 -> "Accepted" 65 | | 203 -> "Non authoritative information" 66 | | 204 -> "No content" 67 | | 205 -> "Reset content" 68 | | 206 -> "Partial content" 69 | | 300 -> "Multiple choices" 70 | | 301 -> "Moved permanently" 71 | | 302 -> "Found" 72 | | 303 -> "See other" 73 | | 304 -> "Not modified" 74 | | 305 -> "Use proxy" 75 | | 307 -> "Temporary redirect" 76 | | 400 -> "Bad request" 77 | | 401 -> "Unauthorized" 78 | | 402 -> "Payment required" 79 | | 403 -> "Forbidden" 80 | | 404 -> "Not found" 81 | | 405 -> "Method not allowed" 82 | | 406 -> "Not acceptable" 83 | | 407 -> "Proxy authentication required" 84 | | 408 -> "Request time out" 85 | | 409 -> "Conflict" 86 | | 410 -> "Gone" 87 | | 411 -> "Length required" 88 | | 412 -> "Precondition failed" 89 | | 413 -> "Request entity too large" 90 | | 414 -> "Request URI too large" 91 | | 415 -> "Unsupported media type" 92 | | 416 -> "Requested range not satisfiable" 93 | | 417 -> "Expectation failed" 94 | | 500 -> "Internal server error" 95 | | 501 -> "Not implemented" 96 | | 502 -> "Bad gateway" 97 | | 503 -> "Service unavailable" 98 | | 504 -> "Gateway time out" 99 | | 505 -> "HTTP version not supported" 100 | | invalid_code -> raise (Invalid_code invalid_code) 101 | 102 | let build_sockaddr (addr, port) = 103 | try 104 | Unix.ADDR_INET ((Unix.gethostbyname addr).Unix.h_addr_list.(0), port) 105 | with Not_found -> failwith ("OCaml-HTTP, can't resolve hostname: " ^ addr) 106 | 107 | let explode_sockaddr = function 108 | | Unix.ADDR_INET (addr, port) -> (Unix.string_of_inet_addr addr, port) 109 | | _ -> assert false (* can explode only inet address *) 110 | 111 | let peername_of_out_channel outchan = 112 | Unix.getpeername (Unix.descr_of_out_channel outchan) 113 | let peername_of_in_channel inchan = 114 | Unix.getpeername (Unix.descr_of_in_channel inchan) 115 | let sockname_of_out_channel outchan = 116 | Unix.getsockname (Unix.descr_of_out_channel outchan) 117 | let sockname_of_in_channel inchan = 118 | Unix.getsockname (Unix.descr_of_in_channel inchan) 119 | 120 | let buf_of_inchan ?limit ic = 121 | let buf = Buffer.create 10240 in 122 | let tmp = Bytes.make 1024 '\000' in 123 | let rec buf_of_inchan' limit = 124 | (match limit with 125 | | None -> 126 | let bytes = input ic tmp 0 1024 in 127 | if bytes > 0 then begin 128 | Buffer.add_subbytes buf tmp 0 bytes; 129 | buf_of_inchan' None 130 | end 131 | | Some lim -> (* TODO what about using a single really_input call? *) 132 | let bytes = input ic tmp 0 (min lim 1024) in 133 | if bytes > 0 then begin 134 | Buffer.add_subbytes buf tmp 0 bytes; 135 | buf_of_inchan' (Some (lim - bytes)) 136 | end) 137 | in 138 | (try buf_of_inchan' limit with End_of_file -> ()); 139 | buf 140 | 141 | let list_assoc_all key pairs = 142 | snd (List.split (List.filter (fun (k, v) -> k = key) pairs)) 143 | 144 | let warn msg = prerr_endline (sprintf "ocaml-http WARNING: %s" msg) 145 | let error msg = prerr_endline (sprintf "ocaml-http ERROR: %s" msg) 146 | 147 | let finally at_end f arg = 148 | let res = 149 | try f arg 150 | with exn -> at_end (); raise exn 151 | in 152 | at_end (); 153 | res 154 | 155 | -------------------------------------------------------------------------------- /http_misc.mli: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2005> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU Library General Public License as 9 | published by the Free Software Foundation, version 2. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU Library General Public License for more details. 15 | 16 | You should have received a copy of the GNU Library General Public 17 | License along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | (** Helpers and other not better classified functions which should not be 23 | exposed in the final API *) 24 | 25 | (** @return the current date compliant to RFC 1123, which updates RFC 822 26 | zone info are retrieved from UTC *) 27 | val date_822: unit -> string 28 | 29 | (** @return true if 'name' is a directory on the file system, false otherwise 30 | *) 31 | val is_directory: string -> bool 32 | 33 | (** @return the filesize of fname *) 34 | val filesize: string -> int 35 | 36 | (** strip trailing '/', if any, from a string and @return the new string *) 37 | val strip_trailing_slash: string -> string 38 | 39 | (** strip heading '/', if any, from a string and @return the new string *) 40 | val strip_heading_slash: string -> string 41 | 42 | (** given a dir handle @return a list of entries contained *) 43 | val ls: Unix.dir_handle -> string list 44 | 45 | (** explode a string in a char list *) 46 | val string_explode: string -> char list 47 | 48 | (** implode a char list in a string *) 49 | val string_implode: char list -> string 50 | 51 | (** given an HTTP response code return the corresponding reason phrase *) 52 | val reason_phrase_of_code: int -> string 53 | 54 | (** build a Unix.sockaddr inet address from a string representation of an IP 55 | address and a port number *) 56 | val build_sockaddr: string * int -> Unix.sockaddr 57 | 58 | (** explode an _inet_ Unix.sockaddr address in a string representation of an 59 | IP address and a port number *) 60 | val explode_sockaddr: Unix.sockaddr -> string * int 61 | 62 | (** given an out_channel build on top of a socket, return peername related to 63 | that socket *) 64 | val peername_of_out_channel: out_channel -> Unix.sockaddr 65 | 66 | (** as above but works on in_channels *) 67 | val peername_of_in_channel: in_channel -> Unix.sockaddr 68 | 69 | (** given an out_channel build on top of a socket, return sockname related to 70 | that socket *) 71 | val sockname_of_out_channel: out_channel -> Unix.sockaddr 72 | 73 | (** as above but works on in_channels *) 74 | val sockname_of_in_channel: in_channel -> Unix.sockaddr 75 | 76 | (* TODO replace with Buffer.add_channel which does almost the same :-((( *) 77 | (** reads from an input channel till it End_of_file and returns what has been 78 | read; if limit is given returned buffer will contains at most first 'limit' 79 | bytes read from input channel *) 80 | val buf_of_inchan: ?limit: int -> in_channel -> Buffer.t 81 | 82 | (** like List.assoc but return all bindings of a given key instead of the 83 | leftmost one only *) 84 | val list_assoc_all: 'a -> ('a * 'b) list -> 'b list 85 | 86 | val warn: string -> unit (** print a warning msg to stderr. Adds trailing \n *) 87 | val error: string -> unit (** print an error msg to stderr. Adds trailing \n *) 88 | 89 | (** @param finalizer finalization function (execution both in case of success 90 | * and in case of raised exception 91 | * @param f function to be invoked 92 | * @param arg argument to be passed to function *) 93 | val finally: (unit -> unit) -> ('a -> 'b) -> 'a -> 'b 94 | 95 | -------------------------------------------------------------------------------- /http_parser.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2010> Stefano Zacchiroli 6 | <2010> Arlen Cuss 7 | 8 | This program is free software; you can redistribute it and/or modify 9 | it under the terms of the GNU Library General Public License as 10 | published by the Free Software Foundation, version 2. 11 | 12 | This program is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | GNU Library General Public License for more details. 16 | 17 | You should have received a copy of the GNU Library General Public 18 | License along with this program; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 20 | USA 21 | *) 22 | 23 | open Printf;; 24 | 25 | open Http_common;; 26 | open Http_types;; 27 | open Http_constants;; 28 | 29 | let (bindings_sep, binding_sep, pieces_sep, header_sep) = 30 | (Pcre.regexp "&", Pcre.regexp "=", Pcre.regexp " ", Pcre.regexp ":") 31 | let header_RE = Pcre.regexp "([^:]*):(.*)" 32 | 33 | let url_decode url = Netencoding.Url.decode ~plus:true url 34 | 35 | let split_query_params query = 36 | let bindings = Pcre.split ~rex:bindings_sep query in 37 | match bindings with 38 | | [] -> [] 39 | | bindings -> 40 | List.map 41 | (fun binding -> 42 | match Pcre.split ~rex:binding_sep binding with 43 | | [ ""; b ] -> (* '=b' *) 44 | raise (Malformed_query_part (binding, query)) 45 | | [ a; b ] -> (* 'a=b' *) (url_decode a, url_decode b) 46 | | [ a ] -> (* 'a=' || 'a' *) (url_decode a, "") 47 | | _ -> raise (Malformed_query_part (binding, query))) 48 | bindings 49 | 50 | (** internal, used by generic_input_line *) 51 | exception Line_completed;; 52 | 53 | (** given an input channel and a separator 54 | @return a line read from it (like Pervasives.input_line) 55 | line is returned only after reading a separator string; separator string isn't 56 | included in the returned value 57 | TODO what about efficiency?, input is performed char-by-char 58 | *) 59 | let generic_input_line ~sep ~ic = 60 | let sep_len = String.length sep in 61 | if sep_len < 1 then 62 | failwith ("Separator '" ^ sep ^ "' is too short!") 63 | else (* valid separator *) 64 | let line = ref "" in 65 | let sep_pointer = ref 0 in 66 | try 67 | while true do 68 | if !sep_pointer >= String.length sep then (* line completed *) 69 | raise Line_completed 70 | else begin (* incomplete line: need to read more *) 71 | let ch = input_char ic in 72 | if ch = String.get sep !sep_pointer then (* next piece of sep *) 73 | incr sep_pointer 74 | else begin (* useful char *) 75 | for i = 0 to !sep_pointer - 1 do 76 | line := !line ^ (String.make 1 (String.get sep i)) 77 | done; 78 | sep_pointer := 0; 79 | line := !line ^ (String.make 1 ch) 80 | end 81 | end 82 | done; 83 | assert false (* unreacheable statement *) 84 | with Line_completed -> !line 85 | 86 | let patch_empty_path = function "" -> "/" | s -> s 87 | let debug_dump_request path params = 88 | debug_print 89 | (sprintf 90 | "recevied request; path: %s; params: %s" 91 | path 92 | (String.concat ", " (List.map (fun (n, v) -> n ^ "=" ^ v) params))) 93 | 94 | let parse_request_fst_line ic = 95 | let request_line = generic_input_line ~sep:crlf ~ic in 96 | debug_print (sprintf "HTTP request line (not yet parsed): %s" request_line); 97 | try 98 | (match Pcre.split ~rex:pieces_sep request_line with 99 | | [ meth_raw; uri_raw ] -> (* ancient HTTP request line *) 100 | (method_of_string meth_raw, (* method *) 101 | Http_parser_sanity.url_of_string uri_raw, (* uri *) 102 | None) (* no version given *) 103 | | [ meth_raw; uri_raw; http_version_raw ] -> (* HTTP 1.{0,1} *) 104 | (method_of_string meth_raw, (* method *) 105 | Http_parser_sanity.url_of_string uri_raw, (* uri *) 106 | Some (version_of_string http_version_raw)) (* version *) 107 | | _ -> raise (Malformed_request request_line)) 108 | with Malformed_URL url -> raise (Malformed_request_URI url) 109 | 110 | let parse_response_fst_line ic = 111 | let response_line = generic_input_line ~sep:crlf ~ic in 112 | debug_print (sprintf "HTTP response line (not yet parsed): %s" response_line); 113 | try 114 | (match Pcre.split ~rex:pieces_sep response_line with 115 | | version_raw :: code_raw :: _ -> 116 | (version_of_string version_raw, (* method *) 117 | status_of_code (int_of_string code_raw)) (* status *) 118 | | _ -> raise (Malformed_response response_line)) 119 | with 120 | | Malformed_URL _ | Invalid_code _ | Failure "int_of_string" -> 121 | raise (Malformed_response response_line) 122 | 123 | let parse_path uri = patch_empty_path (String.concat "/" (Neturl.url_path uri)) 124 | let parse_query_get_params uri = 125 | try (* act on HTTP encoded URIs *) 126 | split_query_params (Neturl.url_query ~encoded:true uri) 127 | with Not_found -> [] 128 | 129 | let parse_headers ic = 130 | (* consume also trailing "^\r\n$" line *) 131 | let rec parse_headers' headers = 132 | match generic_input_line ~sep:crlf ~ic with 133 | | "" -> List.rev headers 134 | | line -> 135 | (let subs = 136 | try 137 | Pcre.extract ~rex:header_RE line 138 | with Not_found -> raise (Invalid_header line) 139 | in 140 | let header = 141 | try 142 | subs.(1) 143 | with Invalid_argument "Array.get" -> raise (Invalid_header line) 144 | in 145 | let value = 146 | try 147 | Http_parser_sanity.normalize_header_value subs.(2) 148 | with Invalid_argument "Array.get" -> "" 149 | in 150 | Http_parser_sanity.heal_header (header, value); 151 | parse_headers' ((header, value) :: headers)) 152 | in 153 | parse_headers' [] 154 | 155 | let parse_cookies raw_cookies = 156 | let tokens = 157 | let lexbuf = Lexing.from_string raw_cookies in 158 | let rec aux acc = 159 | match Cookie_lexer.token lexbuf with 160 | | `EOF -> acc 161 | | token -> aux (token :: acc) 162 | in 163 | List.rev (aux []) 164 | in 165 | let rec aux = function 166 | | [ `ASSIGNMENT (n,v) ] -> [ (n,v) ] 167 | | `ASSIGNMENT (n,v) :: `SEP :: tl -> (n,v) :: aux tl 168 | | _ -> prerr_endline ("failed to read raw cookies: '" ^ raw_cookies ^ "'"); 169 | raise (Malformed_cookies raw_cookies) 170 | in 171 | aux tokens 172 | 173 | let parse_request ic = 174 | let (meth, uri, version) = parse_request_fst_line ic in 175 | let path = parse_path uri in 176 | let query_get_params = parse_query_get_params uri in 177 | debug_dump_request path query_get_params; 178 | (path, query_get_params) 179 | 180 | -------------------------------------------------------------------------------- /http_parser.mli: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2005> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU Library General Public License as 9 | published by the Free Software Foundation, version 2. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU Library General Public License for more details. 15 | 16 | You should have received a copy of the GNU Library General Public 17 | License along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | (** HTTP messages parsing *) 23 | 24 | open Http_types;; 25 | 26 | (** given an HTTP like query string (e.g. "name1=value1&name2=value2&...") 27 | @return a list of pairs [("name1", "value1"); ("name2", "value2")] 28 | @raise Malformed_query if the string isn't a valid query string 29 | @raise Malformed_query_part if some piece of the query isn't valid 30 | *) 31 | val split_query_params: string -> (string * string) list 32 | 33 | (** parse 1st line of an HTTP request 34 | @param inchan input channel from which parse request 35 | @return a triple meth * url * version, meth is the HTTP method invoked, url is 36 | the requested url, version is the HTTP version specified or None if no version 37 | was specified 38 | @raise Malformed_request if request 1st linst isn't well formed 39 | @raise Malformed_request_URI if requested URI isn't well formed *) 40 | val parse_request_fst_line: in_channel -> meth * Neturl.url * version option 41 | 42 | (** parse 1st line of an HTTP response 43 | * @param inchan input channel from which parse response 44 | * @raise Malformed_response if first line isn't well formed 45 | *) 46 | val parse_response_fst_line: in_channel -> version * status 47 | 48 | (** parse HTTP GET parameters from an URL; paramater which were passed with no 49 | value (like 'x' in "/foo.cgi?a=10&x=&c=9") are returned associated with the 50 | empty ("") string. 51 | @return a list of pairs param_name * param_value *) 52 | val parse_query_get_params: Neturl.url -> (string * string) list 53 | 54 | (** parse the base path (removing query string, fragment, ....) from an URL *) 55 | val parse_path: Neturl.url -> string 56 | 57 | (** parse HTTP headers. Consumes also trailing CRLF at the end of header list 58 | @param inchan input channel from which parse headers 59 | @return a list of pairs header_name * header_value 60 | @raise Invalid_header if a not well formed header is encountered *) 61 | val parse_headers: in_channel -> (string * string) list 62 | 63 | (** parse a Cookie header, extracting an associative list . See RFC 2965 65 | * @param raw_cookies: value of a "Cookies:" header 66 | * @return a list of pairs cookie_name * cookie_value 67 | * @raise Malformed_cookies if raw_cookies does not conform to RFC 2965 *) 68 | val parse_cookies: string -> (string * string) list 69 | 70 | (** given an input channel, reads from it a GET HTTP request and 71 | @return a pair where path is a string representing the 72 | requested path and query_params is a list of pairs (the GET 73 | parameters) *) 74 | val parse_request: in_channel -> string * (string * string) list 75 | 76 | -------------------------------------------------------------------------------- /http_parser_sanity.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2005> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU Library General Public License as 9 | published by the Free Software Foundation, version 2. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU Library General Public License for more details. 15 | 16 | You should have received a copy of the GNU Library General Public 17 | License along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | open Printf 23 | 24 | open Http_types 25 | open Http_constants 26 | 27 | (* 28 | type url_syntax_option = 29 | Url_part_not_recognized 30 | | Url_part_allowed 31 | | Url_part_required 32 | 33 | * (1) scheme://user:password@host:port/path;params?query#fragment 34 | *) 35 | 36 | let request_uri_syntax = 37 | { 38 | Neturl.url_enable_scheme = Neturl.Url_part_not_recognized; 39 | url_enable_user = Neturl.Url_part_not_recognized; 40 | url_enable_user_param = Neturl.Url_part_not_recognized; 41 | url_enable_password = Neturl.Url_part_not_recognized; 42 | url_enable_host = Neturl.Url_part_not_recognized; 43 | url_enable_port = Neturl.Url_part_not_recognized; 44 | url_enable_path = Neturl.Url_part_required; 45 | url_enable_param = Neturl.Url_part_not_recognized; 46 | url_enable_query = Neturl.Url_part_allowed; 47 | url_enable_fragment = Neturl.Url_part_not_recognized; 48 | url_enable_other = Neturl.Url_part_not_recognized; 49 | url_accepts_8bits = false; 50 | url_enable_relative = true; 51 | url_is_valid = (fun _ -> true); 52 | } 53 | 54 | (* convention: 55 | foo_RE_raw is the uncompiled regexp matching foo 56 | foo_RE is the compiled regexp matching foo 57 | is_foo is the predicate over string matching foo 58 | *) 59 | 60 | let separators_RE_raw = "()<>@,;:\\\\\"/\\[\\]?={} \t" 61 | let ctls_RE_raw = "\\x00-\\x1F\\x7F" 62 | let token_RE_raw = "[^" ^ separators_RE_raw ^ ctls_RE_raw ^ "]+" 63 | let lws_RE_raw = "(\r\n)?[ \t]" 64 | let quoted_string_RE_raw = "\"(([^\"])|(\\\\\"))*\"" 65 | let text_RE_raw = "(([^" ^ ctls_RE_raw ^ "])|(" ^ lws_RE_raw ^ "))+" 66 | let field_content_RE_raw = 67 | sprintf 68 | "^(((%s)|(%s)|(%s))|(%s))*$" 69 | token_RE_raw 70 | separators_RE_raw 71 | quoted_string_RE_raw 72 | text_RE_raw 73 | (* 74 | (* following RFC 2616 specifications *) 75 | let field_value_RE_raw = "((" ^ field_content_RE_raw ^ ")|(" ^ lws_RE_raw^ "))*" 76 | *) 77 | (* smarter implementation: TEXT production is included in the regexp below *) 78 | let field_value_RE_raw = 79 | sprintf 80 | "^((%s)|(%s)|(%s)|(%s))*$" 81 | token_RE_raw 82 | separators_RE_raw 83 | quoted_string_RE_raw 84 | lws_RE_raw 85 | 86 | let token_RE = Pcre.regexp ("^" ^ token_RE_raw ^ "$") 87 | let field_value_RE = Pcre.regexp ("^" ^ field_value_RE_raw ^ "$") 88 | let heading_lws_RE = Pcre.regexp (sprintf "^%s*" lws_RE_raw) 89 | let trailing_lws_RE = Pcre.regexp (sprintf "%s*$" lws_RE_raw) 90 | 91 | let is_token s = Pcre.pmatch ~rex:token_RE s 92 | let is_field_name = is_token 93 | let is_field_value s = Pcre.pmatch ~rex:field_value_RE s 94 | 95 | let heal_header_name s = 96 | if not (is_field_name s) then raise (Invalid_header_name s) else () 97 | 98 | let heal_header_value s = 99 | if not (is_field_value s) then raise (Invalid_header_value s) else () 100 | 101 | let normalize_header_value s = 102 | Pcre.replace ~rex:trailing_lws_RE 103 | (Pcre.replace ~rex:heading_lws_RE s) 104 | 105 | let heal_header (name, value) = 106 | heal_header_name name; 107 | heal_header_value name 108 | 109 | let url_of_string s = 110 | try 111 | Neturl.url_of_string request_uri_syntax s 112 | with Neturl.Malformed_URL -> raise (Malformed_URL s) 113 | 114 | let string_of_url = Neturl.string_of_url 115 | 116 | -------------------------------------------------------------------------------- /http_parser_sanity.mli: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2005> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU Library General Public License as 9 | published by the Free Software Foundation, version 2. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU Library General Public License for more details. 15 | 16 | You should have received a copy of the GNU Library General Public 17 | License along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | (** Sanity test functions related to HTTP message parsing *) 23 | 24 | (** @param name an HTTP header name 25 | @raise Invalid_header_name if name isn't a valid HTTP header name *) 26 | val heal_header_name: string -> unit 27 | 28 | (** @param value an HTTP header value 29 | @raise Invalid_header_value if value isn't a valid HTTP header value *) 30 | val heal_header_value: string -> unit 31 | 32 | (** @param header a pair header_name * header_value 33 | @raise Invalid_header_name if name isn't a valid HTTP header name 34 | @raise Invalid_header_value if value isn't a valid HTTP header value *) 35 | val heal_header: string * string -> unit 36 | 37 | (** remove heading and/or trailing LWS sequences as per RFC2616 *) 38 | val normalize_header_value: string -> string 39 | 40 | (** parse an URL from a string. 41 | @raise Malformed_URL if an invalid URL is encountered *) 42 | val url_of_string: string -> Neturl.url 43 | 44 | (** pretty print an URL *) 45 | val string_of_url: Neturl.url -> string 46 | 47 | -------------------------------------------------------------------------------- /http_request.ml: -------------------------------------------------------------------------------- 1 | (* 2 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 3 | 4 | Copyright (C) <2002-2007> Stefano Zacchiroli 5 | 6 | This program is free software; you can redistribute it and/or modify 7 | it under the terms of the GNU Library General Public License as 8 | published by the Free Software Foundation, version 2. 9 | 10 | This program is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU Library General Public License for more details. 14 | 15 | You should have received a copy of the GNU Library General Public 16 | License along with this program; if not, write to the Free Software 17 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 18 | USA 19 | *) 20 | 21 | open Printf;; 22 | 23 | open Http_common;; 24 | open Http_types;; 25 | 26 | let debug_dump_request path params = 27 | debug_print ("request path = " ^ path); 28 | debug_print ( 29 | sprintf"request params = %s" 30 | (String.concat ";" 31 | (List.map (fun (h,v) -> String.concat "=" [h;v]) params))) 32 | 33 | let auth_sep_RE = Pcre.regexp ":" 34 | let basic_auth_RE = Pcre.regexp "^Basic\\s+" 35 | 36 | exception Fallback;; (* used internally by request class *) 37 | 38 | class request ic = 39 | let (meth, uri, version) = Http_parser.parse_request_fst_line ic in 40 | let uri_str = Neturl.string_of_url uri in 41 | let path = Http_parser.parse_path uri in 42 | let query_get_params = Http_parser.parse_query_get_params uri in 43 | let (headers, body) = 44 | (match version with 45 | | None -> [], "" (* No version given, use request's 1st line only *) 46 | | Some version -> (* Version specified, parse also headers and body *) 47 | let headers = 48 | List.map (* lowercase header names to ease lookups before having a 49 | request object *) 50 | (fun (h,v) -> (String.lowercase_ascii h, v)) 51 | (Http_parser.parse_headers ic) (* trailing \r\n consumed! *) 52 | in 53 | let body = 54 | (* TODO fallback on size defined in Transfer-Encoding if 55 | Content-Length isn't defined *) 56 | match meth with 57 | | `POST | `PUT | `TRACE -> 58 | Buffer.contents 59 | (try (* read only Content-Length bytes *) 60 | let limit_raw = 61 | (try 62 | List.assoc "content-length" headers 63 | with Not_found -> raise Fallback) 64 | in 65 | let limit = 66 | (try (* TODO supports only a maximum content-length of 1Gb *) 67 | int_of_string limit_raw 68 | with Failure "int_of_string" -> 69 | raise (Invalid_header ("content-length: " ^ limit_raw))) 70 | in 71 | Http_misc.buf_of_inchan ~limit ic 72 | with Fallback -> Http_misc.buf_of_inchan ic) (* read until EOF *) 73 | | _ -> 74 | "" 75 | in 76 | (headers, body)) 77 | in 78 | let cookies = 79 | try 80 | let _hdr, raw_cookies = 81 | List.find 82 | (fun (hdr, _cookie) -> String.lowercase_ascii hdr = "cookie") 83 | headers 84 | in 85 | Some (Http_parser.parse_cookies raw_cookies) 86 | with 87 | | Not_found -> None 88 | | Malformed_cookies _ -> None 89 | in 90 | let query_post_params = 91 | match meth with 92 | | `POST -> 93 | let ct = try List.assoc "content-type" headers with Not_found -> "" in 94 | if ct = "application/x-www-form-urlencoded" then 95 | Http_parser.split_query_params body 96 | else [] 97 | | _ -> [] 98 | in 99 | let params = query_post_params @ query_get_params in (* prefers POST params *) 100 | let _ = debug_dump_request path params in 101 | let (clisockaddr, srvsockaddr) = 102 | (Http_misc.peername_of_in_channel ic, Http_misc.sockname_of_in_channel ic) 103 | in 104 | 105 | object (self) 106 | 107 | inherit 108 | Http_message.message ~body ~headers ~version ~clisockaddr ~srvsockaddr 109 | 110 | val params_tbl = 111 | let tbl = Hashtbl.create (List.length params) in 112 | List.iter (fun (n,v) -> Hashtbl.add tbl n v) params; 113 | tbl 114 | 115 | method meth = meth 116 | method uri = uri_str 117 | method path = path 118 | method param ?(meth: meth option) ?(default: string option) name = 119 | try 120 | (match meth with 121 | | None -> Hashtbl.find params_tbl name 122 | | Some `GET -> List.assoc name query_get_params 123 | | Some `HEAD -> List.assoc name query_get_params 124 | | Some `PUT -> List.assoc name query_get_params 125 | | Some `DELETE -> List.assoc name query_get_params 126 | | Some `OPTIONS -> List.assoc name query_get_params 127 | | Some `TRACE -> List.assoc name query_get_params 128 | | Some `POST -> List.assoc name query_post_params) 129 | with Not_found -> 130 | (match default with 131 | | None -> raise (Param_not_found name) 132 | | Some value -> value) 133 | method paramAll ?meth name = 134 | (match (meth: meth option) with 135 | | None -> List.rev (Hashtbl.find_all params_tbl name) 136 | | Some `GET -> Http_misc.list_assoc_all name query_get_params 137 | | Some `HEAD -> Http_misc.list_assoc_all name query_get_params 138 | | Some `PUT -> Http_misc.list_assoc_all name query_get_params 139 | | Some `DELETE -> Http_misc.list_assoc_all name query_get_params 140 | | Some `OPTIONS -> Http_misc.list_assoc_all name query_get_params 141 | | Some `TRACE -> Http_misc.list_assoc_all name query_get_params 142 | | Some `POST -> Http_misc.list_assoc_all name query_post_params) 143 | method params = params 144 | method params_GET = query_get_params 145 | method params_POST = query_post_params 146 | 147 | method cookies = cookies 148 | 149 | method private fstLineToString = 150 | let method_string = string_of_method self#meth in 151 | match self#version with 152 | | Some version -> 153 | sprintf "%s %s %s" method_string self#uri (string_of_version version) 154 | | None -> sprintf "%s %s" method_string self#uri 155 | 156 | method authorization: auth_info option = 157 | try 158 | let credentials = 159 | Netencoding.Base64.decode 160 | (Pcre.replace ~rex:basic_auth_RE (self#header "authorization")) 161 | in 162 | debug_print ("HTTP Basic auth credentials: " ^ credentials); 163 | (match Pcre.split ~rex:auth_sep_RE credentials with 164 | | [username; password] -> Some (`Basic (username, password)) 165 | | l -> raise Exit) 166 | with Header_not_found _ | Invalid_argument _ | Exit -> None 167 | 168 | end 169 | 170 | -------------------------------------------------------------------------------- /http_request.mli: -------------------------------------------------------------------------------- 1 | (* 2 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 3 | 4 | Copyright (C) <2002-2007> Stefano Zacchiroli 5 | 6 | This program is free software; you can redistribute it and/or modify 7 | it under the terms of the GNU Library General Public License as 8 | published by the Free Software Foundation, version 2. 9 | 10 | This program is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU Library General Public License for more details. 14 | 15 | You should have received a copy of the GNU Library General Public 16 | License along with this program; if not, write to the Free Software 17 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 18 | USA 19 | *) 20 | 21 | (** Object Oriented representation of HTTP requests *) 22 | 23 | open Http_types;; 24 | 25 | (** OO representation of an HTTP request 26 | @param inchan input channel from which parse an HTTP request *) 27 | class request: in_channel -> Http_types.request 28 | 29 | -------------------------------------------------------------------------------- /http_response.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2005> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU Library General Public License as 9 | published by the Free Software Foundation, version 2. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU Library General Public License for more details. 15 | 16 | You should have received a copy of the GNU Library General Public 17 | License along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | open Http_types;; 23 | open Http_constants;; 24 | open Http_common;; 25 | open Http_daemon;; 26 | open Printf;; 27 | 28 | let status_line_RE = Pcre.regexp "^(HTTP/\\d\\.\\d) (\\d{3}) (.*)$" 29 | 30 | let anyize = function 31 | | Some addr -> addr 32 | | None -> Unix.ADDR_INET (Unix.inet_addr_any, -1) 33 | 34 | class response 35 | (* Warning: keep default values in sync with Http_daemon.respond function *) 36 | ?(body = "") ?(headers = []) ?(version = http_version) 37 | ?clisockaddr ?srvsockaddr (* optional because response have to be easily 38 | buildable in callback functions *) 39 | ?(code = 200) ?status 40 | () 41 | = 42 | 43 | (** if no address were supplied for client and/or server, use a foo address 44 | instead *) 45 | let (clisockaddr, srvsockaddr) = (anyize clisockaddr, anyize srvsockaddr) in 46 | 47 | (* "version code reason_phrase" *) 48 | object (self) 49 | 50 | (* note that response objects can't be created with a None version *) 51 | inherit 52 | Http_message.message 53 | ~body ~headers ~version:(Some version) ~clisockaddr ~srvsockaddr 54 | 55 | val mutable _code = 56 | match status with 57 | | None -> code 58 | | Some (s: Http_types.status) -> code_of_status s 59 | val mutable _reason: string option = None 60 | 61 | method private getRealVersion = 62 | match self#version with 63 | | None -> 64 | failwith ("Http_response.fstLineToString: " ^ 65 | "can't serialize an HTTP response with no HTTP version defined") 66 | | Some v -> string_of_version v 67 | 68 | method code = _code 69 | method setCode c = 70 | ignore (status_of_code c); (* sanity check on c *) 71 | _code <- c 72 | method status = status_of_code _code 73 | method setStatus (s: Http_types.status) = _code <- code_of_status s 74 | method reason = 75 | match _reason with 76 | | None -> Http_misc.reason_phrase_of_code _code 77 | | Some r -> r 78 | method setReason r = _reason <- Some r 79 | method statusLine = 80 | String.concat " " 81 | [self#getRealVersion; string_of_int self#code; self#reason] 82 | method setStatusLine s = 83 | try 84 | let subs = Pcre.extract ~rex:status_line_RE s in 85 | self#setVersion (version_of_string subs.(1)); 86 | self#setCode (int_of_string subs.(2)); 87 | self#setReason subs.(3) 88 | with Not_found -> 89 | raise (Invalid_status_line s) 90 | 91 | method isInformational = is_informational _code 92 | method isSuccess = is_success _code 93 | method isRedirection = is_redirection _code 94 | method isClientError = is_client_error _code 95 | method isServerError = is_server_error _code 96 | method isError = is_error _code 97 | 98 | method addBasicHeaders = 99 | List.iter (fun (n,v) -> self#addHeader n v) (get_basic_headers ()) 100 | 101 | method contentType = self#header "Content-Type" 102 | method setContentType t = self#replaceHeader "Content-Type" t 103 | method contentEncoding = self#header "Content-Encoding" 104 | method setContentEncoding e = self#replaceHeader "Content-Encoding" e 105 | method date = self#header "Date" 106 | method setDate d = self#replaceHeader "Date" d 107 | method expires = self#header "Expires" 108 | method setExpires t = self#replaceHeader "Expires" t 109 | method server = self#header "Server" 110 | method setServer s = self#replaceHeader "Server" s 111 | method connection = self#header "Connection" 112 | method setConnection s = self#replaceHeader "Connection" s 113 | 114 | method private fstLineToString = 115 | sprintf "%s %d %s" self#getRealVersion self#code self#reason 116 | 117 | end 118 | 119 | -------------------------------------------------------------------------------- /http_response.mli: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2005> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU Library General Public License as 9 | published by the Free Software Foundation, version 2. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU Library General Public License for more details. 15 | 16 | You should have received a copy of the GNU Library General Public 17 | License along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | (** Object Oriented representation of HTTP responses *) 23 | 24 | open Http_types;; 25 | 26 | (** OO representation of an HTTP response. *) 27 | class response: 28 | ?body:string -> ?headers:(string * string) list -> ?version: version -> 29 | ?clisockaddr: Unix.sockaddr -> ?srvsockaddr: Unix.sockaddr -> 30 | ?code:int -> ?status:Http_types.status -> 31 | unit -> 32 | Http_types.response 33 | 34 | -------------------------------------------------------------------------------- /http_tcp_server.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2005> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU Library General Public License as 9 | published by the Free Software Foundation, version 2. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU Library General Public License for more details. 15 | 16 | You should have received a copy of the GNU Library General Public 17 | License along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | 23 | (** raised when a client timeouts *) 24 | exception Timeout 25 | 26 | let backlog = 10 27 | 28 | (** if timeout is given (Some _) @return a new callback which establish 29 | timeout_callback as callback for signal Sys.sigalrm and register an alarm 30 | (expiring after timeout seconds) before invoking the real callback given. If 31 | timeout is None, callback is returned unchanged. *) 32 | let wrap_callback_w_timeout ~callback ~timeout ~timeout_callback = 33 | match timeout with 34 | | None -> callback 35 | | Some timeout -> (* wrap callback setting an handler for ALRM signal and an 36 | alarm that ring after timeout seconds *) 37 | (fun inchan outchan -> 38 | ignore (Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_callback)); 39 | ignore (Unix.alarm timeout); 40 | callback inchan outchan) 41 | 42 | (* try to close nicely a socket *) 43 | let shutdown_socket suck = 44 | try 45 | Unix.shutdown suck Unix.SHUTDOWN_ALL 46 | with Unix.Unix_error(_, "shutdown", "") -> () 47 | 48 | let nice_unix_accept suck = 49 | try 50 | Unix.accept suck 51 | with e -> (* clean up socket before exit *) 52 | shutdown_socket suck; 53 | raise e 54 | 55 | let init_socket sockaddr = 56 | let suck = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in 57 | (* shutdown socket on SIGTERM *) 58 | ignore (Sys.signal Sys.sigterm 59 | (Sys.Signal_handle 60 | (fun _ -> shutdown_socket suck; exit 17))); 61 | Unix.setsockopt suck Unix.SO_REUSEADDR true; 62 | Unix.bind suck sockaddr; 63 | Unix.listen suck backlog; 64 | suck 65 | 66 | let init_callback callback timeout = 67 | let timeout_callback signo = 68 | if signo = Sys.sigalrm then 69 | raise Timeout 70 | in 71 | wrap_callback_w_timeout ~callback ~timeout ~timeout_callback 72 | 73 | (** try to close an outchannel connected to a socket, ignore Sys_error since 74 | * this probably means that socket is already closed (e.g. on sigpipe) *) 75 | let try_close_out ch = try close_out ch with Sys_error _ -> () 76 | 77 | (** like Unix.establish_server, but shutdown sockets when receiving SIGTERM 78 | and before exiting for an uncaught exception *) 79 | let my_establish_server server_fun sockaddr = 80 | let suck = init_socket sockaddr in 81 | while true do 82 | let (s, caller) = nice_unix_accept suck in 83 | (** "double fork" trick, see {!Unix.establish_server} implementation *) 84 | match Unix.fork() with 85 | | 0 -> (* parent *) 86 | (try 87 | if Unix.fork () <> 0 then 88 | exit 0; (* The son exits, the grandson works *) 89 | let inchan = Unix.in_channel_of_descr s in 90 | let outchan = Unix.out_channel_of_descr s in 91 | server_fun inchan outchan; 92 | try_close_out outchan; (* closes also inchan: socket is the same *) 93 | exit 0 94 | with e -> 95 | shutdown_socket suck; (* clean up socket before exit *) 96 | raise e) 97 | | child when (child > 0) -> (* child *) 98 | Unix.close s; 99 | ignore (Unix.waitpid [] child) (* Reclaim the son *) 100 | | _ (* < 0 *) -> 101 | failwith "Can't fork" 102 | done 103 | 104 | (** tcp_server which forks a new process for each request *) 105 | let fork ~sockaddr ~timeout callback = 106 | let timeout_callback signo = 107 | if signo = Sys.sigalrm then 108 | exit 2 109 | in 110 | my_establish_server 111 | (wrap_callback_w_timeout ~callback ~timeout ~timeout_callback) 112 | sockaddr 113 | 114 | (** tcp_server which doesn't fork, requests are server sequentially and in the 115 | same address space of the calling process *) 116 | let simple ~sockaddr ~timeout callback = 117 | let suck = init_socket sockaddr in 118 | let callback = init_callback callback timeout in 119 | try 120 | while true do 121 | let (client, _) = Unix.accept suck in 122 | (* client is now connected *) 123 | let (inchan, outchan) = 124 | (Unix.in_channel_of_descr client, Unix.out_channel_of_descr client) 125 | in 126 | (try 127 | callback inchan outchan; 128 | ignore (Unix.alarm 0) (* reset alarm *) 129 | with Timeout -> ()); 130 | try_close_out outchan (* this close also inchan: socket is the same *) 131 | done 132 | with e -> (* clean up socket before exit *) 133 | shutdown_socket suck; 134 | raise e 135 | 136 | (** tcp_server which creates a new thread for each request to be served *) 137 | let thread ~sockaddr ~timeout callback = 138 | let suck = init_socket sockaddr in 139 | let callback = init_callback callback timeout in 140 | let callback (i, o) = 141 | (try 142 | callback i o 143 | with 144 | | Timeout -> () 145 | | e -> 146 | try_close_out o; 147 | raise e); 148 | try_close_out o 149 | in 150 | while true do 151 | let (client, _) = nice_unix_accept suck in 152 | (* client is now connected *) 153 | let (inchan, outchan) = 154 | (Unix.in_channel_of_descr client, Unix.out_channel_of_descr client) 155 | in 156 | Http_threaded_tcp_server.serve callback (inchan, outchan) 157 | done 158 | 159 | (** @param server an Http_types.tcp_server 160 | * @return an Http_types.tcp_server which takes care of ignoring SIGPIPE during 161 | * server execution and restoring previous handler when (if ever) the server 162 | * returns *) 163 | let handle_sigpipe server = 164 | fun ~sockaddr ~timeout callback -> 165 | let old_sigpipe_behavior = Sys.signal Sys.sigpipe Sys.Signal_ignore in 166 | server ~sockaddr ~timeout callback; 167 | ignore (Sys.signal Sys.sigpipe old_sigpipe_behavior) 168 | 169 | let simple = handle_sigpipe simple 170 | let thread = handle_sigpipe thread 171 | let fork = handle_sigpipe fork 172 | 173 | -------------------------------------------------------------------------------- /http_tcp_server.mli: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2005> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU Library General Public License as 9 | published by the Free Software Foundation, version 2. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU Library General Public License for more details. 15 | 16 | You should have received a copy of the GNU Library General Public 17 | License along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | (** TCP servers used as low-levels for HTTP daemons *) 23 | 24 | (** {2 servers} *) 25 | 26 | (** single process server *) 27 | val simple: Http_types.tcp_server 28 | 29 | (** multi threaded server *) 30 | val thread: Http_types.tcp_server 31 | 32 | (** multi process server *) 33 | val fork: Http_types.tcp_server 34 | 35 | (** {2 low level functions} *) 36 | 37 | (** initialize a passive socket listening on given Unix.sockaddr *) 38 | val init_socket: Unix.sockaddr -> Unix.file_descr 39 | 40 | -------------------------------------------------------------------------------- /http_threaded_tcp_server.mli: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2005> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU Library General Public License as 9 | published by the Free Software Foundation, version 2. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU Library General Public License for more details. 15 | 16 | You should have received a copy of the GNU Library General Public 17 | License along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | (** Multithreaded part of Http_tcp_server *) 23 | 24 | (** serve an HTTP request for a multi threaded TCP server *) 25 | val serve : ('a -> 'b) -> 'a -> unit 26 | 27 | -------------------------------------------------------------------------------- /http_types.ml: -------------------------------------------------------------------------------- 1 | (* 2 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 3 | 4 | Copyright (C) <2002-2007> Stefano Zacchiroli 5 | 6 | This program is free software; you can redistribute it and/or modify 7 | it under the terms of the GNU Library General Public License as 8 | published by the Free Software Foundation, version 2. 9 | 10 | This program is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU Library General Public License for more details. 14 | 15 | You should have received a copy of the GNU Library General Public 16 | License along with this program; if not, write to the Free Software 17 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 18 | USA 19 | *) 20 | 21 | (** Type definitions *) 22 | 23 | type version = [ `HTTP_1_0 | `HTTP_1_1 ] 24 | type meth = [ `GET | `POST | `HEAD | `PUT | `DELETE | `OPTIONS | `TRACE] 25 | type daemon_mode = [ `Single | `Fork | `Thread ] 26 | 27 | type tcp_server = 28 | sockaddr:Unix.sockaddr -> timeout:int option -> 29 | (in_channel -> out_channel -> unit) -> 30 | unit 31 | 32 | type auth_info = 33 | [ `Basic of string * string (* username, password *) 34 | ] 35 | 36 | type informational_substatus = 37 | [ `Continue 38 | | `Switching_protocols 39 | ] 40 | type success_substatus = 41 | [ `OK 42 | | `Created 43 | | `Accepted 44 | | `Non_authoritative_information 45 | | `No_content 46 | | `Reset_content 47 | | `Partial_content 48 | ] 49 | type redirection_substatus = 50 | [ `Multiple_choices 51 | | `Moved_permanently 52 | | `Found 53 | | `See_other 54 | | `Not_modified 55 | | `Use_proxy 56 | | `Temporary_redirect 57 | ] 58 | type client_error_substatus = 59 | [ `Bad_request 60 | | `Unauthorized 61 | | `Payment_required 62 | | `Forbidden 63 | | `Not_found 64 | | `Method_not_allowed 65 | | `Not_acceptable 66 | | `Proxy_authentication_required 67 | | `Request_time_out 68 | | `Conflict 69 | | `Gone 70 | | `Length_required 71 | | `Precondition_failed 72 | | `Request_entity_too_large 73 | | `Request_URI_too_large 74 | | `Unsupported_media_type 75 | | `Requested_range_not_satisfiable 76 | | `Expectation_failed 77 | ] 78 | type server_error_substatus = 79 | [ `Internal_server_error 80 | | `Not_implemented 81 | | `Bad_gateway 82 | | `Service_unavailable 83 | | `Gateway_time_out 84 | | `HTTP_version_not_supported 85 | ] 86 | type informational_status = [ `Informational of informational_substatus ] 87 | type success_status = [ `Success of success_substatus ] 88 | type redirection_status = [ `Redirection of redirection_substatus ] 89 | type client_error_status = [ `Client_error of client_error_substatus ] 90 | type server_error_status = [ `Server_error of server_error_substatus ] 91 | type error_status = 92 | [ client_error_status 93 | | server_error_status 94 | ] 95 | type status = 96 | [ informational_status 97 | | success_status 98 | | redirection_status 99 | | client_error_status 100 | | server_error_status 101 | ] 102 | 103 | type status_code = [ `Code of int | `Status of status ] 104 | 105 | type file_source = 106 | | FileSrc of string 107 | | InChanSrc of in_channel 108 | 109 | exception Invalid_header of string 110 | exception Invalid_header_name of string 111 | exception Invalid_header_value of string 112 | exception Invalid_HTTP_version of string 113 | exception Invalid_HTTP_method of string 114 | exception Invalid_code of int 115 | exception Malformed_URL of string 116 | exception Malformed_query of string 117 | exception Malformed_query_part of string * string 118 | exception Malformed_request_URI of string 119 | exception Malformed_cookies of string 120 | exception Malformed_request of string 121 | exception Malformed_response of string 122 | exception Param_not_found of string 123 | exception Invalid_status_line of string 124 | exception Header_not_found of string 125 | exception Quit 126 | exception Unauthorized of string 127 | 128 | class type message = object 129 | method version: version option 130 | method setVersion: version -> unit 131 | method body: string 132 | method setBody: string -> unit 133 | method bodyBuf: Buffer.t 134 | method setBodyBuf: Buffer.t -> unit 135 | method addBody: string -> unit 136 | method addBodyBuf: Buffer.t -> unit 137 | method addHeader: name:string -> value:string -> unit 138 | method addHeaders: (string * string) list -> unit 139 | method replaceHeader: name:string -> value:string -> unit 140 | method replaceHeaders: (string * string) list -> unit 141 | method removeHeader: name:string -> unit 142 | method hasHeader: name:string -> bool 143 | method header: name:string -> string 144 | method headers: (string * string) list 145 | method clientSockaddr: Unix.sockaddr 146 | method clientAddr: string 147 | method clientPort: int 148 | method serverSockaddr: Unix.sockaddr 149 | method serverAddr: string 150 | method serverPort: int 151 | method toString: string 152 | method serialize: out_channel -> unit 153 | end 154 | 155 | class type request = object 156 | inherit message 157 | method meth: meth 158 | method uri: string 159 | method path: string 160 | method param: ?meth:meth -> ?default:string -> string -> string 161 | method paramAll: ?meth:meth -> string -> string list 162 | method params: (string * string) list 163 | method params_GET: (string * string) list 164 | method params_POST: (string * string) list 165 | method cookies: (string * string) list option 166 | method authorization: auth_info option 167 | end 168 | 169 | class type response = object 170 | inherit message 171 | method code: int 172 | method setCode: int -> unit 173 | method status: status 174 | method setStatus: status -> unit 175 | method reason: string 176 | method setReason: string -> unit 177 | method statusLine: string 178 | method setStatusLine: string -> unit 179 | method isInformational: bool 180 | method isSuccess: bool 181 | method isRedirection: bool 182 | method isClientError: bool 183 | method isServerError: bool 184 | method isError: bool 185 | method addBasicHeaders: unit 186 | method contentType: string 187 | method setContentType: string -> unit 188 | method contentEncoding: string 189 | method setContentEncoding: string -> unit 190 | method date: string 191 | method setDate: string -> unit 192 | method expires: string 193 | method setExpires: string -> unit 194 | method server: string 195 | method setServer: string -> unit 196 | method connection: string 197 | method setConnection: string -> unit 198 | end 199 | 200 | class type connection = 201 | object 202 | method getRequest: request option 203 | method respond_with: response -> unit 204 | method close: unit 205 | end 206 | class type daemon = 207 | object 208 | method accept: connection 209 | method getRequest: request * connection 210 | end 211 | 212 | type daemon_spec = { 213 | address: string; 214 | auth: (string * auth_info) option; 215 | callback: request -> out_channel -> unit; 216 | mode: daemon_mode; 217 | port: int; 218 | root_dir: string option; 219 | exn_handler: (exn -> out_channel -> unit) option; 220 | timeout: int option; 221 | auto_close: bool; 222 | } 223 | 224 | -------------------------------------------------------------------------------- /http_types.mli: -------------------------------------------------------------------------------- 1 | (* 2 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 3 | 4 | Copyright (C) <2002-2007> Stefano Zacchiroli 5 | 6 | This program is free software; you can redistribute it and/or modify 7 | it under the terms of the GNU Library General Public License as 8 | published by the Free Software Foundation, version 2. 9 | 10 | This program is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU Library General Public License for more details. 14 | 15 | You should have received a copy of the GNU Library General Public 16 | License along with this program; if not, write to the Free Software 17 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 18 | USA 19 | *) 20 | 21 | (** Type definitions *) 22 | 23 | (** HTTP version, actually only 1.0 and 1.1 are supported. Note that 24 | 'supported' here means only 'accepted inside a HTTP request line', no 25 | different behaviours are actually implemented depending on HTTP version *) 26 | type version = 27 | [ `HTTP_1_0 28 | | `HTTP_1_1 29 | ] 30 | 31 | (** HTTP method, actually only GET and POST methods are supported *) 32 | type meth = 33 | [ `GET 34 | | `POST 35 | | `HEAD 36 | | `PUT 37 | | `DELETE 38 | | `OPTIONS 39 | | `TRACE 40 | ] 41 | 42 | (** Daemon behaviour wrt request handling. `Single mode use a single process 43 | to handle all requests, no request is served until a previous one has been 44 | fully served. `Fork mode fork a new process for each request, the new process 45 | will execute the callback function and then exit. `Thread mode create a new 46 | thread for each request, the new thread will execute the callback function and 47 | then exit, threads can communicate using standard OCaml Thread library. *) 48 | type daemon_mode = [ `Single | `Fork | `Thread ] 49 | 50 | (** A TCP server is a function taking an address on which bind and listen for 51 | connections, an optional timeout after which abort client connections and a 52 | callback function which in turn takes an input and an output channel as 53 | arguments. After receiving this argument a TCP server sits and waits for 54 | connection, on each connection it apply the callback function to channels 55 | connected to client. *) 56 | type tcp_server = 57 | sockaddr:Unix.sockaddr -> timeout:int option -> 58 | (in_channel -> out_channel -> unit) -> 59 | unit 60 | 61 | (** authentication information *) 62 | type auth_info = 63 | [ `Basic of string * string (* username, password *) 64 | (* | `Digest of ... (* TODO digest authentication *) *) 65 | ] 66 | 67 | (** @see "RFC2616" informational HTTP status *) 68 | type informational_substatus = 69 | [ `Continue 70 | | `Switching_protocols 71 | ] 72 | 73 | (** @see "RFC2616" success HTTP status *) 74 | type success_substatus = 75 | [ `OK 76 | | `Created 77 | | `Accepted 78 | | `Non_authoritative_information 79 | | `No_content 80 | | `Reset_content 81 | | `Partial_content 82 | ] 83 | 84 | (** @see "RFC2616" redirection HTTP status *) 85 | type redirection_substatus = 86 | [ `Multiple_choices 87 | | `Moved_permanently 88 | | `Found 89 | | `See_other 90 | | `Not_modified 91 | | `Use_proxy 92 | | `Temporary_redirect 93 | ] 94 | 95 | (** @see "RFC2616" client error HTTP status *) 96 | type client_error_substatus = 97 | [ `Bad_request 98 | | `Unauthorized 99 | | `Payment_required 100 | | `Forbidden 101 | | `Not_found 102 | | `Method_not_allowed 103 | | `Not_acceptable 104 | | `Proxy_authentication_required 105 | | `Request_time_out 106 | | `Conflict 107 | | `Gone 108 | | `Length_required 109 | | `Precondition_failed 110 | | `Request_entity_too_large 111 | | `Request_URI_too_large 112 | | `Unsupported_media_type 113 | | `Requested_range_not_satisfiable 114 | | `Expectation_failed 115 | ] 116 | 117 | (** @see "RFC2616" server error HTTP status *) 118 | type server_error_substatus = 119 | [ `Internal_server_error 120 | | `Not_implemented 121 | | `Bad_gateway 122 | | `Service_unavailable 123 | | `Gateway_time_out 124 | | `HTTP_version_not_supported 125 | ] 126 | 127 | type informational_status = [ `Informational of informational_substatus ] 128 | type success_status = [ `Success of success_substatus ] 129 | type redirection_status = [ `Redirection of redirection_substatus ] 130 | type client_error_status = [ `Client_error of client_error_substatus ] 131 | type server_error_status = [ `Server_error of server_error_substatus ] 132 | 133 | type error_status = 134 | [ client_error_status 135 | | server_error_status 136 | ] 137 | 138 | (** HTTP status *) 139 | type status = 140 | [ informational_status 141 | | success_status 142 | | redirection_status 143 | | client_error_status 144 | | server_error_status 145 | ] 146 | 147 | type status_code = [ `Code of int | `Status of status ] 148 | 149 | (** File sources *) 150 | type file_source = 151 | | FileSrc of string (** filename *) 152 | | InChanSrc of in_channel (** input channel *) 153 | 154 | (** {2 Exceptions} *) 155 | 156 | (** invalid header encountered *) 157 | exception Invalid_header of string 158 | 159 | (** invalid header name encountered *) 160 | exception Invalid_header_name of string 161 | 162 | (** invalid header value encountered *) 163 | exception Invalid_header_value of string 164 | 165 | (** unsupported or invalid HTTP version encountered *) 166 | exception Invalid_HTTP_version of string 167 | 168 | (** unsupported or invalid HTTP method encountered *) 169 | exception Invalid_HTTP_method of string 170 | 171 | (** invalid HTTP status code integer representation encountered *) 172 | exception Invalid_code of int 173 | 174 | (** invalid URL encountered *) 175 | exception Malformed_URL of string 176 | 177 | (** invalid query string encountered *) 178 | exception Malformed_query of string 179 | 180 | (** invalid query string part encountered, arguments are parameter name and 181 | parameter value *) 182 | exception Malformed_query_part of string * string 183 | 184 | (** invalid request URI encountered *) 185 | exception Malformed_request_URI of string 186 | 187 | (** malformed cookies *) 188 | exception Malformed_cookies of string 189 | 190 | (** malformed request received *) 191 | exception Malformed_request of string 192 | 193 | (** malformed response received, argument is response's first line *) 194 | exception Malformed_response of string 195 | 196 | (** a parameter you were looking for was not found *) 197 | exception Param_not_found of string 198 | 199 | (** invalid HTTP status line encountered *) 200 | exception Invalid_status_line of string 201 | 202 | (** an header you were looking for was not found *) 203 | exception Header_not_found of string 204 | 205 | (** raisable by callbacks to make main daemon quit, this is the only 206 | * 'clean' way to make start functions return *) 207 | exception Quit 208 | 209 | (** raisable by callbacks to force a 401 (unauthorized) HTTP answer. 210 | * This exception should be raised _before_ sending any data over given out 211 | * channel. 212 | * @param realm authentication realm (usually needed to prompt user) *) 213 | exception Unauthorized of string 214 | 215 | (** {2 OO representation of HTTP messages} *) 216 | 217 | (** HTTP generic messages. See {! Http_message.message} *) 218 | class type message = object 219 | 220 | method version: version option 221 | method setVersion: version -> unit 222 | 223 | method body: string 224 | method setBody: string -> unit 225 | method bodyBuf: Buffer.t 226 | method setBodyBuf: Buffer.t -> unit 227 | method addBody: string -> unit 228 | method addBodyBuf: Buffer.t -> unit 229 | 230 | method addHeader: name:string -> value:string -> unit 231 | method addHeaders: (string * string) list -> unit 232 | method replaceHeader: name:string -> value:string -> unit 233 | method replaceHeaders: (string * string) list -> unit 234 | method removeHeader: name:string -> unit 235 | method hasHeader: name:string -> bool 236 | method header: name:string -> string 237 | method headers: (string * string) list 238 | 239 | method clientSockaddr: Unix.sockaddr 240 | method clientAddr: string 241 | method clientPort: int 242 | 243 | method serverSockaddr: Unix.sockaddr 244 | method serverAddr: string 245 | method serverPort: int 246 | 247 | method toString: string 248 | method serialize: out_channel -> unit 249 | 250 | end 251 | 252 | (** HTTP requests *) 253 | class type request = object 254 | 255 | (** an HTTP request is a flavour of HTTP message *) 256 | inherit message 257 | 258 | (** @return request method *) 259 | method meth: meth 260 | 261 | (** @return requested URI (including query string, fragment, ...) *) 262 | method uri: string 263 | 264 | (** @return requested path *) 265 | method path: string 266 | 267 | (** lookup a given parameter 268 | @param meth if given restrict the lookup area (e.g. if meth = POST than 269 | only parameters received via POST are searched), if not given both GET 270 | and POST parameter are searched in an unspecified order (actually the 271 | implementation prefers POST parameters but this is not granted, you've 272 | been warned) 273 | @param default if provided, this value will be returned in case no 274 | parameter of that name is available instead of raising Param_not_found 275 | @param name name of the parameter to lookup 276 | @return value associated to parameter name 277 | @raise Param_not_found if parameter name was not found *) 278 | method param: ?meth:meth -> ?default:string -> string -> string 279 | 280 | (** like param above but return a list of values associated to given 281 | parameter (a parameter could be defined indeed more than once: passed more 282 | than once in a query string or passed both insider the url (the GET way) 283 | and inside message body (the POST way)) *) 284 | method paramAll: ?meth:meth -> string -> string list 285 | 286 | (** @return the list of all received parameters *) 287 | method params: (string * string) list 288 | 289 | (** @return the list of all parameters received via GET *) 290 | method params_GET: (string * string) list 291 | 292 | (** @return the list of all parameter received via POST *) 293 | method params_POST: (string * string) list 294 | 295 | method cookies: (string * string) list option 296 | 297 | (** @return authorization information, if given by the client *) 298 | method authorization: auth_info option 299 | 300 | end 301 | 302 | (** HTTP responses *) 303 | class type response = object 304 | 305 | inherit message 306 | 307 | (** @return response code *) 308 | method code: int 309 | 310 | (** set response code *) 311 | method setCode: int -> unit 312 | 313 | (** @return response status *) 314 | method status: status 315 | 316 | (** set response status *) 317 | method setStatus: status -> unit 318 | 319 | (** @return reason string *) 320 | method reason: string 321 | 322 | (** set reason string *) 323 | method setReason: string -> unit 324 | 325 | (** @return status line *) 326 | method statusLine: string 327 | 328 | (** set status line 329 | @raise Invalid_status_line if an invalid HTTP status line was passed *) 330 | method setStatusLine: string -> unit 331 | 332 | (** response is an informational one *) 333 | method isInformational: bool 334 | 335 | (** response is a success one *) 336 | method isSuccess: bool 337 | 338 | (** response is a redirection one *) 339 | method isRedirection: bool 340 | 341 | (** response is a client error one *) 342 | method isClientError: bool 343 | 344 | (** response is a server error one *) 345 | method isServerError: bool 346 | 347 | (** response is either a client error or a server error response *) 348 | method isError: bool 349 | 350 | (** add basic headers to response, see {!Http_daemon.send_basic_headers} 351 | *) 352 | method addBasicHeaders: unit 353 | 354 | (** facilities to access some frequently used headers *) 355 | 356 | (** @return Content-Type header value *) 357 | method contentType: string 358 | 359 | (** set Content-Type header value *) 360 | method setContentType: string -> unit 361 | 362 | (** @return Content-Encoding header value *) 363 | method contentEncoding: string 364 | 365 | (** set Content-Encoding header value *) 366 | method setContentEncoding: string -> unit 367 | 368 | (** @return Date header value *) 369 | method date: string 370 | 371 | (** set Date header value *) 372 | method setDate: string -> unit 373 | 374 | (** @return Expires header value *) 375 | method expires: string 376 | 377 | (** set Expires header value *) 378 | method setExpires: string -> unit 379 | 380 | (** @return Server header value *) 381 | method server: string 382 | 383 | (** set Server header value *) 384 | method setServer: string -> unit 385 | 386 | (** @return Connection header value *) 387 | method connection: string 388 | 389 | (** set Connection header value *) 390 | method setConnection: string -> unit 391 | end 392 | 393 | (** {2 Daemon specification} *) 394 | 395 | (** daemon specification, describe the behaviour of an HTTP daemon. 396 | * 397 | * The default daemon specification is {!Http_daemon.default_spec} 398 | *) 399 | type daemon_spec = { 400 | address: string; 401 | (** @param address adress on which daemon will be listening, can be both a 402 | * numeric address (e.g. "127.0.0.1") and an hostname (e.g. "localhost") *) 403 | auth: (string * auth_info) option; 404 | (** authentication requirements (currently only basic authentication is 405 | * supported). If set to None no authentication is required. If set to Some 406 | * ("realm", `Basic ("foo", "bar")), only clients authenticated with baisc 407 | * authentication, for realm "realm", providing username "foo" and password 408 | * "bar" are accepted; others are rejected with a 401 response code *) 409 | callback: request -> out_channel -> unit; 410 | (** function which will be called each time a correct HTTP request will be 411 | * received. 1st callback argument is an Http_types.request object 412 | * corresponding to the request received; 2nd argument is an output channel 413 | * corresponding to the socket connected to the client *) 414 | mode: daemon_mode; 415 | (** requests handling mode, it can have three different values: 416 | * - `Single -> all requests will be handled by the same process, 417 | * - `Fork -> each request will be handled by a child process, 418 | * - `Thread -> each request will be handled by a (new) thread *) 419 | port: int; (** TCP port on which the daemon will be listening *) 420 | root_dir: string option; 421 | (** directory to which ocaml http will chdir before starting handling 422 | * requests; if None, no chdir will be performed (i.e. stay in the current 423 | * working directory) *) 424 | exn_handler: (exn -> out_channel -> unit) option; 425 | (** what to do when executing callback raises an exception. If None, the 426 | * exception will be re-raised: in `Fork/`Thread mode the current 427 | * process/thread will be terminated. in `Single mode the exception is 428 | * ignored and the client socket closed. If Some callback, the callback will 429 | * be executed before acting as per None; the callback is meant to perform 430 | * some clean up actions, like releasing global mutexes in `Thread mode *) 431 | timeout: int option; 432 | (** timeout in seconds after which an incoming HTTP request will be 433 | * terminated closing the corresponding TCP connection; None disable the 434 | * timeout *) 435 | auto_close: bool; 436 | (** whether ocaml-http will automatically close the connection with the 437 | * client after callback has completed its execution. If set to true, close 438 | * will be attempted no matter if the callback raises an exception or not *) 439 | } 440 | 441 | (** {2 OO representation of other HTTP entities} *) 442 | 443 | (** an HTTP connection from a client to a server *) 444 | class type connection = 445 | object 446 | (** @return next request object, may block if client hasn't submitted any 447 | request yet, may be None if client request was ill-formed *) 448 | method getRequest: request option 449 | 450 | (** respond to client sending it a response *) 451 | method respond_with: response -> unit 452 | 453 | (** close connection to client. Warning: this object can't be used any 454 | longer after this method has been called *) 455 | method close: unit 456 | end 457 | 458 | (** an HTTP daemon *) 459 | class type daemon = 460 | object 461 | (** @return a connection to a client, may block if no client has connected 462 | yet *) 463 | method accept: connection 464 | 465 | (** shortcut method, blocks until a client has submit a request and 466 | return a pair request * connection *) 467 | method getRequest: request * connection 468 | end 469 | 470 | -------------------------------------------------------------------------------- /http_user_agent.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2005> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU Library General Public License as 9 | published by the Free Software Foundation, version 2. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU Library General Public License for more details. 15 | 16 | You should have received a copy of the GNU Library General Public 17 | License along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | open Printf 23 | 24 | open Http_common 25 | 26 | exception Http_error of (int * string) (* code, body *) 27 | 28 | let http_scheme_RE = Pcre.regexp ~flags:[`CASELESS] "^http://" 29 | let url_RE = Pcre.regexp "^([\\w.-]+)(:(\\d+))?(/.*)?$" 30 | 31 | let tcp_bufsiz = 4096 (* for TCP I/O *) 32 | 33 | let parse_url url = 34 | try 35 | let subs = 36 | Pcre.extract ~rex:url_RE (Pcre.replace ~rex:http_scheme_RE url) 37 | in 38 | (subs.(1), 39 | (if subs.(2) = "" then 80 else int_of_string subs.(3)), 40 | (if subs.(4) = "" then "/" else subs.(4))) 41 | with exc -> 42 | failwith 43 | (sprintf "Can't parse url: %s (exception: %s)" 44 | url (Printexc.to_string exc)) 45 | 46 | let init_socket addr port = 47 | let inet_addr = (Unix.gethostbyname addr).Unix.h_addr_list.(0) in 48 | let sockaddr = Unix.ADDR_INET (inet_addr, port) in 49 | let suck = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in 50 | Unix.connect suck sockaddr; 51 | let outchan = Unix.out_channel_of_descr suck in 52 | let inchan = Unix.in_channel_of_descr suck in 53 | (inchan, outchan) 54 | 55 | let submit_request kind url = 56 | let (address, port, path) = parse_url url in 57 | let (inchan, outchan) = init_socket address port in 58 | let req_string = match kind with `GET -> "GET" | `HEAD -> "HEAD" in 59 | output_string outchan (sprintf "%s %s HTTP/1.0\r\n" req_string path); 60 | output_string outchan (sprintf "Host: %s\r\n\r\n" address); 61 | flush outchan; 62 | (inchan, outchan) 63 | 64 | let head url = 65 | let (inchan, outchan) = submit_request `HEAD url in 66 | let (_, status) = Http_parser.parse_response_fst_line inchan in 67 | (match code_of_status status with 68 | | 200 -> () 69 | | code -> raise (Http_error (code, ""))); 70 | let buf = Http_misc.buf_of_inchan inchan in 71 | close_in inchan; (* close also outchan, same fd *) 72 | Buffer.contents buf 73 | 74 | let get_iter ?(head_callback = fun _ _ -> ()) callback url = 75 | let (inchan, outchan) = submit_request `GET url in 76 | let buf = Bytes.create tcp_bufsiz in 77 | let (_, status) = Http_parser.parse_response_fst_line inchan in 78 | (match code_of_status status with 79 | | 200 -> () 80 | | code -> raise (Http_error (code, ""))); 81 | let headers = Http_parser.parse_headers inchan in 82 | head_callback status headers; 83 | (try 84 | while true do 85 | match input inchan buf 0 tcp_bufsiz with 86 | | 0 -> raise End_of_file 87 | | bytes when bytes = tcp_bufsiz -> (* buffer full, no need to slice it *) 88 | callback buf 89 | | bytes when bytes < tcp_bufsiz -> (* buffer not full, slice it *) 90 | callback (Bytes.sub buf 0 bytes) 91 | | _ -> (* ( bytes < 0 ) || ( bytes > tcp_bufsiz ) *) 92 | assert false 93 | done 94 | with End_of_file -> ()); 95 | close_in inchan (* close also outchan, same fd *) 96 | 97 | let get ?head_callback url = 98 | let buf = Buffer.create 10240 in 99 | get_iter ?head_callback (Buffer.add_bytes buf) url; 100 | Buffer.contents buf 101 | 102 | -------------------------------------------------------------------------------- /http_user_agent.mli: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002-2005> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU Library General Public License as 9 | published by the Free Software Foundation, version 2. 10 | 11 | This program is distributed in the hope that it will be useful, 12 | but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | GNU Library General Public License for more details. 15 | 16 | You should have received a copy of the GNU Library General Public 17 | License along with this program; if not, write to the Free Software 18 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 19 | USA 20 | *) 21 | 22 | (** Minimal implementation of an HTTP 1.0/1.1 client. Interface is similar to 23 | * Gerd Stoplmann's Http_client module. Implementation is simpler and doesn't 24 | * handle HTTP redirection, proxies, ecc. The only reason for the existence of 25 | * this module is for performances and incremental elaboration of response's 26 | * bodies *) 27 | 28 | open Http_types 29 | 30 | exception Http_error of (int * string) (* code, body *) 31 | 32 | (** @param head_callback optional calllback invoked on response's status and 33 | * headers. If not provided no callback will be invoked 34 | * @param url an HTTP url 35 | * @return HTTP response's body 36 | * @raise Http_error when response code <> 200 *) 37 | val get: 38 | ?head_callback:(status -> (string * string) list -> unit) -> 39 | string -> 40 | string 41 | 42 | (** as above but iter callback function on HTTP response's body instead of 43 | * returning it as a string *) 44 | val get_iter: 45 | ?head_callback:(status -> (string * string) list -> unit) -> 46 | (bytes -> unit) -> string -> 47 | unit 48 | 49 | (** @param url an HTTP url 50 | * @return HTTP HEAD raw response 51 | * @raise Http_error when response code <> 200 *) 52 | val head: string -> string 53 | 54 | -------------------------------------------------------------------------------- /mt/.gitignore: -------------------------------------------------------------------------------- 1 | http_threaded_tcp_server.mli 2 | -------------------------------------------------------------------------------- /mt/http_threaded_tcp_server.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU General Public License as published by 9 | the Free Software Foundation; either version 2 of the License, or 10 | (at your option) any later version. 11 | 12 | This program is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | GNU General Public License for more details. 16 | 17 | You should have received a copy of the GNU General Public License 18 | along with this program; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | let serve callback arg = ignore (Thread.create callback arg) 23 | 24 | -------------------------------------------------------------------------------- /non_mt/.gitignore: -------------------------------------------------------------------------------- 1 | http_threaded_tcp_server.mli 2 | -------------------------------------------------------------------------------- /non_mt/http_threaded_tcp_server.ml: -------------------------------------------------------------------------------- 1 | 2 | (* 3 | OCaml HTTP - do it yourself (fully OCaml) HTTP daemon 4 | 5 | Copyright (C) <2002> Stefano Zacchiroli 6 | 7 | This program is free software; you can redistribute it and/or modify 8 | it under the terms of the GNU General Public License as published by 9 | the Free Software Foundation; either version 2 of the License, or 10 | (at your option) any later version. 11 | 12 | This program is distributed in the hope that it will be useful, 13 | but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | GNU General Public License for more details. 16 | 17 | You should have received a copy of the GNU General Public License 18 | along with this program; if not, write to the Free Software 19 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 20 | *) 21 | 22 | let serve _ _ = 23 | failwith 24 | ("Threaded server not supported by the non threaded version " ^ 25 | "of ocaml-http, please link against http_mt.cm{,x}a") 26 | 27 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | version: "0.1.6" 3 | maintainer: "claudio.sacerdoticoen@unibo.it" 4 | bug-reports: "https://github.com/sacerdot/ocaml-http/issues" 5 | homepage: "https://github.com/sacerdot/ocaml-http" 6 | authors: "Stefano Zacchiroli" 7 | dev-repo: "git+https://github.com/sacerdot/ocaml-http.git" 8 | build: [ 9 | [make "all"] 10 | [make "opt"] 11 | ] 12 | remove: [["ocamlfind" "remove" "http"]] 13 | depends: ["ocaml" {>="4.03.0"} "ocamlfind" {build} "ocamlnet" "pcre"] 14 | install: [make "install"] 15 | synopsis: "Library freely inspired from Perl's HTTP::Daemon module" 16 | flags: light-uninstall 17 | --------------------------------------------------------------------------------