diff --git a/.travis-ci.sh b/.travis-ci.sh index 1169593014..4be0ba9c34 100755 --- a/.travis-ci.sh +++ b/.travis-ci.sh @@ -20,7 +20,8 @@ echo OPAM versions opam --version opam --git-version -opam init git://github.com/ocaml/opam-repository >/dev/null 2>&1 +# opam init git://github.com/ocaml/opam-repository >/dev/null 2>&1 +opam init opam install ${OPAM_DEPENDS} eval `opam config env` diff --git a/CHANGES b/CHANGES index c3735ae37c..5110df1281 100644 --- a/CHANGES +++ b/CHANGES @@ -1,3 +1,13 @@ +0.9.14 (2013-12-15): +* Install a `cohttp-server` binary that serves local directory contents via a web server (#54). +* Add a `flush` function to the `IO` module type and implement in Lwt/Async/Mirage. +* Add option `flush` support in the Async and Lwt responders (#52). +* Autogenerate HTTP codes from @citricsquid's JSON representation of the HTTP RFCs. +* Always set `TCP_NODELAY` for Lwt/Unix server sockets for low-latency responses (#58). +* Added a Server-Side Events test-case from the HTML5 Doctor. See `lib_test/README.md`. +* Async.Server response now takes an optional `body` rather than a mandatory `body option` (#62). +* Regenerate build system using OASIS 0.4.0. + 0.9.13 (2013-12-10): * The `cohttp.lwt-core` is now installed as an OS-independent Lwt library. * Add support for Mirage 1.0, via `cohttp.mirage-unix` and `cohttp.mirage-xen`. diff --git a/README.md b/README.md index ad3ef0902e..fb971a4df1 100644 --- a/README.md +++ b/README.md @@ -4,16 +4,23 @@ libraries: * `Cohttp_lwt_unix` uses the [Lwt](http://ocsigen.org/lwt) library, and specifically the UNIX bindings. -* `Cohttp_async` uses the [Async](https://bitbucket.org/yminsky/ocaml-core/wiki/DummiesGuideToAsync) -library from Jane Street. -* `Cohttp_lwt_mirage` uses the [Mirage](http://www.openmirage.org) interface +* `Cohttp_async` uses the [Async](https://realworldocaml.org/v1/en/html/concurrent-programming-with-async.html) +library. +* `Cohttp_mirage` uses the [Mirage](http://www.openmirage.org) interface to generate standalone microkernels. -You can implement other targets using parser very easily. Look at the -`lib/IO.ml` signature, and implement that in the desired backend. +You can implement other targets using the parser very easily. Look at the +`lib/IO.mli` signature and implement that in the desired backend. You can activate some runtime debugging by setting `COHTTP_DEBUG` to any value, and all requests and responses will be written to stderr. For build requirements, please see the `_oasis` file, or use OPAM to install -it from http://github.com/OCamlPro/opam +it from . + +## Simple HTTP server + +If you install the Async dependency, then a `cohttp-server` binary will also be +built and installed that acts in a similar fashion to the Python +`SimpleHTTPServer`. Just run `cohttp-server` in a directory and it will +open up a local port and serve the files over HTTP. diff --git a/_oasis b/_oasis index af55022c89..322d1213a1 100644 --- a/_oasis +++ b/_oasis @@ -1,9 +1,9 @@ OASISFormat: 0.3 Name: cohttp -Version: 0.9.13 +Version: 0.9.14 Synopsis: HTTP library for Lwt, Async and Mirage Authors: Anil Madhavapeddy, Stefano Zacchiroli, David Sheets, Thomas Gazagnaire, David Scott -License: LGPL-2.0 with OCaml linking exception +License: ISC Plugins: META (0.3) BuildTools: ocamlbuild @@ -241,14 +241,14 @@ Executable test_net_async_server Install: false BuildDepends: cohttp, cohttp.async, oUnit (>= 1.0.2) -#Executable "cohttp-async-server" -# Path: bin -# MainIs: cohttp_server_async.ml -# Build$: flag(tests) && flag(async) -# Custom: true -# CompiledObject: best -# Install: true -# BuildDepends: cohttp, cohttp.async +Executable "cohttp-server" + Path: bin + MainIs: cohttp_server_async.ml + Build$: flag(tests) && flag(async) + Custom: true + CompiledObject: best + Install: true + BuildDepends: cohttp, cohttp.async Test test_accept Run$: flag(tests) diff --git a/_tags b/_tags index b8effd23ca..9903d242f5 100644 --- a/_tags +++ b/_tags @@ -1,7 +1,7 @@ # OASIS_START -# DO NOT EDIT (digest: 191919a1b412de614ac25c71f18ab0da) -# Ignore VCS directories, you can use the same kind of rule outside -# OASIS_START/STOP if you want to exclude directories that contains +# DO NOT EDIT (digest: 34cfc630efe139056434de798589c0f0) +# Ignore VCS directories, you can use the same kind of rule outside +# OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process <**/.svn>: -traverse <**/.svn>: not_hygienic @@ -282,9 +282,29 @@ : pkg_fieldslib : pkg_fieldslib.syntax : custom +# Executable cohttp-server +: use_cohttp_async +: use_cohttp +: pkg_uri +: pkg_async_core +: pkg_async_unix +: pkg_threads +: pkg_async +: pkg_re +: pkg_uri.services +: pkg_fieldslib +: pkg_fieldslib.syntax +: use_cohttp_async +: use_cohttp +: pkg_uri +: pkg_async_core +: pkg_async_unix +: pkg_threads +: pkg_async +: pkg_re +: pkg_uri.services +: pkg_fieldslib +: pkg_fieldslib.syntax +: custom # OASIS_STOP -: syntax_camlp4o, pkg_lwt.syntax - or or : syntax_camlp4o, pkg_fieldslib.syntax -: syntax_camlp4o, pkg_lwt.syntax -: syntax_camlp4o, pkg_lwt.syntax true: annot, bin_annot, debug, strict_sequence, principal diff --git a/async/cohttp_async.ml b/async/cohttp_async.ml index 9174735d93..5a1e26a60b 100644 --- a/async/cohttp_async.ml +++ b/async/cohttp_async.ml @@ -89,6 +89,9 @@ module IO = struct Writer.write oc "\r\n"; return () ) + + let flush oc = + Writer.flushed oc end module Net = struct @@ -238,33 +241,43 @@ module Server = struct >>= fun response -> response wr - let respond ?headers ~body status : response = + let respond ?(flush=false) ?headers ?body status : response = fun wr -> let headers = Cohttp.Header.add_opt headers "connection" "close" in match body with | None -> - let res = Response.make ~status ~encoding:(Cohttp.Transfer.Fixed 0) ~headers () in + let res = Response.make ~status ~flush ~encoding:(Cohttp.Transfer.Fixed 0) ~headers () in Response.write_header res wr >>= fun () -> Response.write_footer res wr >>= fun () -> Writer.close wr | Some body -> - let res = Response.make ~status ~encoding:Cohttp.Transfer.Chunked ~headers () in + let res = Response.make ~status ~flush ~encoding:Cohttp.Transfer.Chunked ~headers () in Response.write_header res wr >>= fun () -> - Pipe.iter body ~f:(Response.write_body res wr) + Pipe.iter body ~f:(fun buf -> + Response.write_body res wr buf + >>= fun () -> + (match flush with + | true -> Writer.flushed wr + | false -> return ()) + ) >>= fun () -> Response.write_footer res wr >>= fun () -> Writer.close wr - let respond_with_pipe ?headers ?(code=`OK) body = - return (respond ?headers ~body:(Some body) code) + let respond_with_pipe ?flush ?headers ?(code=`OK) body = + return (respond ?flush ?headers ~body code) - let respond_with_string ?headers ?(code=`OK) body = + let respond_with_string ?flush ?headers ?(code=`OK) body = let body = Pipe.of_list [body] in - return (respond ?headers ~body:(Some body) code) + return (respond ?flush ?headers ~body code) + + let respond_with_redirect ?headers uri = + let headers = Cohttp.Header.add_opt headers "location" (Uri.to_string uri) in + return (respond ~flush:false ~headers `Found) let resolve_local_file ~docroot ~uri = (* This normalises the Uri and strips out .. characters *) @@ -274,13 +287,13 @@ module Server = struct let error_body_default = "

404 Not Found

" - let respond_with_file ?headers ?error_body filename = + let respond_with_file ?flush ?headers ?error_body filename = Monitor.try_with ~run:`Now (fun () -> Reader.open_file filename >>= fun rd -> let body = Reader.pipe rd in - return (respond ?headers ~body:(Some body) `OK) + return (respond ?flush ?headers ~body `OK) ) >>= function |Ok res -> return res diff --git a/async/cohttp_async.mli b/async/cohttp_async.mli index 7872db8d10..bd74bd87e9 100644 --- a/async/cohttp_async.mli +++ b/async/cohttp_async.mli @@ -89,8 +89,6 @@ module Client : sig Uri.t -> (Response.t * string Pipe.Reader.t) Deferred.t - - (** Send an HTTP request with arbitrary method and string Pipe.Reader.t *) val call : ?interrupt:unit Deferred.t -> @@ -112,8 +110,9 @@ module Server : sig type response val respond : + ?flush:bool -> ?headers:Cohttp.Header.t -> - body:string Pipe.Reader.t option -> + ?body:string Pipe.Reader.t -> Cohttp.Code.status_code -> response (** Resolve a URI and a docroot into a concrete local filename. *) @@ -122,17 +121,26 @@ module Server : sig (** Respond with a [string] Pipe that provides the response string Pipe.Reader.t. @param code Default is HTTP 200 `OK *) val respond_with_pipe : + ?flush:bool -> ?headers:Cohttp.Header.t -> ?code:Cohttp.Code.status_code -> string Pipe.Reader.t -> response Deferred.t - (** Respond with a static [string] string Pipe.Reader.t + (** Respond with a static [string] @param code Default is HTTP 200 `OK *) val respond_with_string : + ?flush:bool -> ?headers:Cohttp.Header.t -> ?code:Cohttp.Code.status_code -> string -> response Deferred.t + (** Respond with a redirect to an absolute [uri] + @param uri Absolute URI to redirect the client to *) + val respond_with_redirect : + ?headers:Cohttp.Header.t -> Uri.t -> response Deferred.t + + (** Respond with file contents, and [error_string Pipe.Reader.t] if the file isn't found *) val respond_with_file : + ?flush:bool -> ?headers:Cohttp.Header.t -> ?error_body:string -> string -> response Deferred.t diff --git a/bin/cohttp_server_async.ml b/bin/cohttp_server_async.ml new file mode 100644 index 0000000000..0895f1efd5 --- /dev/null +++ b/bin/cohttp_server_async.ml @@ -0,0 +1,113 @@ +(* + * Copyright (c) 2013 Anil Madhavapeddy + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + * + *) + +open Core.Std +open Async.Std +open Cohttp_async + +let serve_file ~docroot ~uri = + Server.resolve_local_file ~docroot ~uri + |> Server.respond_with_file + +(** HTTP handler *) +let rec handler ~info ~docroot ~verbose ~index ~body sock req = + let uri = Cohttp.Request.uri req in + let path = Uri.path uri in + (* Get a canonical filename from the URL and docroot *) + let file_name = Server.resolve_local_file ~docroot ~uri in + Unix.stat file_name + >>= fun stat -> + (* Log the request to the console *) + printf "%s %s %s\n" + (Cohttp.(Code.string_of_method (Request.meth req))) + path + (match verbose with + | true -> Sexp.to_string_hum (Unix.Stats.sexp_of_t stat) + | false -> "" + ); + match stat.Unix.Stats.kind with + (* Get a list of current files and map to HTML *) + | `Directory -> begin + (* Check if the index file exists *) + Sys.file_exists (Filename.concat file_name index) + >>= function + | `Yes -> (* Serve the index file directly *) + let uri = Uri.with_path uri (Filename.concat path index) in + Server.respond_with_redirect uri + | `No | `Unknown -> (* Do a directory listing *) + Sys.ls_dir file_name + >>= Deferred.List.map ~f:(fun f -> + let file_name = Filename.concat file_name f in + Unix.stat file_name + >>= fun stat -> + let li l = sprintf "
  • %s
  • " (Uri.to_string l) in + let link = Uri.with_path uri (Filename.concat path f) in + match stat.Unix.Stats.kind with + | `Directory -> return (li link (sprintf "%s/" f)) + | `File -> return (li link f) + | `Socket|`Block|`Fifo|`Char|`Link -> return (sprintf "%s" f)) + (* Concatenate the HTML into a response *) + >>= fun html -> + String.concat ~sep:"\n" html + |> fun contents -> + sprintf " + + +

    Directory Listing for %s

    +
      %s
    +
    %s + + " + file_name contents info + |> Server.respond_with_string + end + (* Serve the local file contents *) + | `File -> serve_file ~docroot ~uri + (* Any other file type is simply forbidden *) + | `Socket | `Block | `Fifo | `Char | `Link -> + Server.respond_with_string ~code:`Forbidden + "

    Forbidden

    +

    This is not a normal file or directory

    " + +let start_server docroot port host index verbose () = + printf "Listening for HTTP requests on: %s %d\n" host port; + let info = sprintf "Served by Cohttp/Async listening on %s:%d" host port in + Unix.Inet_addr.of_string_or_getbyname host + >>= fun host -> + let listen_on = Tcp.Where_to_listen.create + ~socket_type:Socket.Type.tcp + ~address:(`Inet (host,port)) + ~listening_on:(fun _ -> port) + in + Server.create + ~on_handler_error:`Ignore + listen_on + (handler ~info ~docroot ~index ~verbose) + >>= fun _ -> never () + +let _ = + Command.async_basic + ~summary:"Serve the local directory contents via HTTP" + Command.Spec.( + empty + +> anon (maybe_with_default "." ("docroot" %: string)) + +> flag "-p" (optional_with_default 8080 int) ~doc:"port TCP port to listen on" + +> flag "-s" (optional_with_default "0.0.0.0" string) ~doc:"address IP address to listen on" + +> flag "-i" (optional_with_default "index.html" string) ~doc:"file Name of index file in directory" + +> flag "-v" (optional_with_default false bool) ~doc:" Verbose logging output to console" + ) start_server + |> Command.run diff --git a/cohttp.obuild b/cohttp.obuild deleted file mode 100644 index 7160721256..0000000000 --- a/cohttp.obuild +++ /dev/null @@ -1,106 +0,0 @@ -Name: cohttp -Version: 0.9.8 -Synopsis: HTTP library for Lwt, Async and Mirage -Authors: Anil Madhavapeddy, Stefano Zacchiroli, David Sheets, Thomas Gazagnaire, David Scott -License: LGPL-2.0 with OCaml linking exception -obuild-ver: 1 - -Flag lwt - Description: build the Lwt library - Default: true - -Flag async - Description: build the Core/Async library - Default: true - -Flag mirage - Description: build the Mirage library - Default: true - -Flag nettests - Description: run the internet-using tests - Default: false - -Library cohttp - Modules: Cohttp - BuildDepends: re, uri (>= 1.3.8), uri.services - - Library lwt - Path: lwt - Buildable: $lwt - BuildDepends: lwt.unix, lwt, uri, cohttp, lwt.syntax, ssl - pp: camlp4o - Modules: Cohttp_lwt_unix_io, Cohttp_lwt_unix, Cohttp_lwt, Cohttp_lwt_body, Cohttp_lwt_unix_net - - Library mirage - Path: lwt - Buildable: $mirage - BuildDepends: uri, re, cohttp, lwt.syntax, mirage, mirage-net - pp: camlp4o - Modules: Cohttp_lwt_mirage_io, Cohttp_lwt_mirage, Cohttp_lwt, Cohttp_lwt_body - - Library async - Path: async - Buildable: $async - BuildDepends: uri, cohttp, async_core >= 108.07.00, async_unix, threads, async - Modules: Cohttp_async - -Test parser - Path: lib_test - MainIs: test_parser.ml - BuildDepends: cohttp, cohttp.lwt, oUnit >= 1.0.2 - -Test accept - Path: lib_test - MainIs: test_accept.ml - BuildDepends: cohttp, oUnit >= 1.0.2 - rundir: lib_test - -Test header - Path: lib_test - MainIs: test_header.ml - BuildDepends: cohttp, oUnit >= 1.0.2 - rundir: lib_test - -Test net_lwt - Path: lib_test - MainIs: test_net_lwt.ml - BuildDepends: cohttp, cohttp.lwt, oUnit >= 1.0.2 - rundir: lib_test - -Test net_lwt_google - Path: lib_test - MainIs: test_net_lwt_google.ml - BuildDepends: cohttp.lwt - rundir: lib_test - -Test net_lwt_server - Path: lib_test - MainIs: test_net_lwt_server.ml - BuildDepends: cohttp, cohttp.lwt - rundir: lib_test - -Test net_lwt_client_and_server - Path: lib_test - MainIs: test_net_lwt_client_and_server.ml - BuildDepends: cohttp, cohttp.lwt - rundir: lib_test - -Test net_mirage_server - Path: lib_test - MainIs: test_net_mirage_server.ml - BuildDepends: cohttp, cohttp.mirage - rundir: lib_test - -Test net_async - Path: lib_test - MainIs: test_net_async.ml - BuildDepends: cohttp, cohttp.async, oUnit (>= 1.0.2) - rundir: lib_test - -Test net_async_server - Path: lib_test - MainIs: test_net_async_server.ml - BuildDepends: cohttp, cohttp.async, oUnit (>= 1.0.2) - rundir: lib_test - diff --git a/cohttp/IO.mli b/cohttp/IO.mli index 358ee9b802..25e729c773 100644 --- a/cohttp/IO.mli +++ b/cohttp/IO.mli @@ -13,4 +13,5 @@ module type S = sig val read_exactly : ic -> int -> string option t val write : oc -> string -> unit t + val flush : oc -> unit t end diff --git a/cohttp/META b/cohttp/META index 0cd29490a6..fd77333f2e 100644 --- a/cohttp/META +++ b/cohttp/META @@ -1,6 +1,6 @@ # OASIS_START -# DO NOT EDIT (digest: 5ef394ff982ae649a5fec90a7b6a6298) -version = "0.9.13" +# DO NOT EDIT (digest: c094b1d1abaf3376efc541edae3ee304) +version = "0.9.14" description = "HTTP library for Lwt, Async and Mirage" requires = "re uri uri.services fieldslib fieldslib.syntax" archive(byte) = "cohttp.cma" @@ -9,7 +9,7 @@ archive(native) = "cohttp.cmxa" archive(native, plugin) = "cohttp.cmxs" exists_if = "cohttp.cma" package "mirage-xen" ( - version = "0.9.13" + version = "0.9.14" description = "HTTP library for Lwt, Async and Mirage" requires = "cohttp.lwt-core mirage-types cstruct mirage-tcpip-xen" archive(byte) = "cohttp_mirage_xen.cma" @@ -20,7 +20,7 @@ package "mirage-xen" ( ) package "mirage-unix" ( - version = "0.9.13" + version = "0.9.14" description = "HTTP library for Lwt, Async and Mirage" requires = "cohttp.lwt-core mirage-types cstruct mirage-tcpip-unix" archive(byte) = "cohttp_mirage_unix.cma" @@ -31,7 +31,7 @@ package "mirage-unix" ( ) package "lwt-core" ( - version = "0.9.13" + version = "0.9.14" description = "HTTP library for Lwt, Async and Mirage" requires = "lwt uri cohttp lwt.syntax" archive(byte) = "cohttp_lwt.cma" @@ -42,7 +42,7 @@ package "lwt-core" ( ) package "lwt" ( - version = "0.9.13" + version = "0.9.14" description = "HTTP library for Lwt, Async and Mirage" requires = "cohttp.lwt-core unix lwt.unix lwt.ssl" archive(byte) = "cohttp_lwt_unix.cma" @@ -53,7 +53,7 @@ package "lwt" ( ) package "async" ( - version = "0.9.13" + version = "0.9.14" description = "HTTP library for Lwt, Async and Mirage" requires = "uri cohttp async_core async_unix threads async" archive(byte) = "cohttp_async.cma" diff --git a/cohttp/code.ml b/cohttp/code.ml index df5dd3b838..f0d794a5f4 100644 --- a/cohttp/code.ml +++ b/cohttp/code.ml @@ -1,33 +1,16 @@ -(* - OCaml HTTP - do it yourself (fully OCaml) HTTP daemon - - Copyright (C) <2002-2005> Stefano Zacchiroli - Copyright (C) <2009> Anil Madhavapeddy - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU Library General Public License as - published by the Free Software Foundation, version 2. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 - USA -*) - -(** Type definitions *) +(* Auto-Generated by 'ocaml generate.ml' *) type version = [ `HTTP_1_0 | `HTTP_1_1 ] -type meth = [ `GET | `POST | `HEAD | `DELETE |`PATCH |`PUT | `OPTIONS ] + +type meth = [ `GET | `POST | `HEAD | `DELETE | `PATCH | `PUT | `OPTIONS ] type informational_status = [ `Continue | `Switching_protocols + | `Processing + | `Checkpoint ] + type success_status = [ `OK | `Created @@ -36,7 +19,11 @@ type success_status = | `No_content | `Reset_content | `Partial_content + | `Multi_status + | `Already_reported + | `Im_used ] + type redirection_status = [ `Multiple_choices | `Moved_permanently @@ -44,8 +31,11 @@ type redirection_status = | `See_other | `Not_modified | `Use_proxy + | `Switch_proxy | `Temporary_redirect + | `Resume_incomplete ] + type client_error_status = [ `Bad_request | `Unauthorized @@ -55,30 +45,49 @@ type client_error_status = | `Method_not_allowed | `Not_acceptable | `Proxy_authentication_required - | `Request_time_out + | `Request_timeout | `Conflict | `Gone | `Length_required | `Precondition_failed | `Request_entity_too_large - | `Request_URI_too_large + | `Request_uri_too_long | `Unsupported_media_type | `Requested_range_not_satisfiable | `Expectation_failed + | `I_m_a_teapot + | `Enhance_your_calm | `Unprocessable_entity + | `Locked + | `Failed_dependency + | `Upgrade_required + | `Precondition_required + | `Too_many_requests + | `Request_header_fields_too_large + | `No_response + | `Retry_with + | `Blocked_by_windows_parental_controls + | `Wrong_exchange_server + | `Client_closed_request ] + type server_error_status = [ `Internal_server_error | `Not_implemented | `Bad_gateway | `Service_unavailable - | `Gateway_time_out - | `HTTP_version_not_supported - ] -type error_status = - [ client_error_status - | server_error_status + | `Gateway_timeout + | `Http_version_not_supported + | `Variant_also_negotiates + | `Insufficient_storage + | `Loop_detected + | `Bandwidth_limit_exceeded + | `Not_extended + | `Network_authentication_required + | `Network_read_timeout_error + | `Network_connect_timeout_error ] + type status = [ informational_status | success_status @@ -87,29 +96,27 @@ type status = | server_error_status ] -type status_code = [ `Code of int | status ] - -(* Manipulate the code types *) +type status_code = [`Code of int | status ] -let string_of_version = function +let string_of_version: version -> string = function | `HTTP_1_0 -> "HTTP/1.0" | `HTTP_1_1 -> "HTTP/1.1" -let version_of_string = function +let version_of_string: string -> version option = function | "HTTP/1.0" -> Some `HTTP_1_0 | "HTTP/1.1" -> Some `HTTP_1_1 | _ -> None -let string_of_method = function +let string_of_method: meth -> string = function | `GET -> "GET" | `POST -> "POST" | `HEAD -> "HEAD" | `DELETE -> "DELETE" | `PATCH -> "PATCH" - | `OPTIONS -> "OPTIONS" | `PUT -> "PUT" + | `OPTIONS -> "OPTIONS" -let method_of_string = function +let method_of_string: string -> meth option = function | "GET" -> Some `GET | "POST" -> Some `POST | "HEAD" -> Some `HEAD @@ -119,9 +126,11 @@ let method_of_string = function | "OPTIONS" -> Some `OPTIONS | _ -> None -let status_of_code (x:int) : status_code = match x with +let status_of_code: int -> status_code = function | 100 -> `Continue | 101 -> `Switching_protocols + | 102 -> `Processing + | 103 -> `Checkpoint | 200 -> `OK | 201 -> `Created | 202 -> `Accepted @@ -129,13 +138,18 @@ let status_of_code (x:int) : status_code = match x with | 204 -> `No_content | 205 -> `Reset_content | 206 -> `Partial_content + | 207 -> `Multi_status + | 208 -> `Already_reported + | 226 -> `Im_used | 300 -> `Multiple_choices | 301 -> `Moved_permanently | 302 -> `Found | 303 -> `See_other | 304 -> `Not_modified | 305 -> `Use_proxy + | 306 -> `Switch_proxy | 307 -> `Temporary_redirect + | 308 -> `Resume_incomplete | 400 -> `Bad_request | 401 -> `Unauthorized | 402 -> `Payment_required @@ -144,28 +158,51 @@ let status_of_code (x:int) : status_code = match x with | 405 -> `Method_not_allowed | 406 -> `Not_acceptable | 407 -> `Proxy_authentication_required - | 408 -> `Request_time_out + | 408 -> `Request_timeout | 409 -> `Conflict | 410 -> `Gone | 411 -> `Length_required | 412 -> `Precondition_failed | 413 -> `Request_entity_too_large - | 414 -> `Request_URI_too_large + | 414 -> `Request_uri_too_long | 415 -> `Unsupported_media_type | 416 -> `Requested_range_not_satisfiable | 417 -> `Expectation_failed + | 418 -> `I_m_a_teapot + | 420 -> `Enhance_your_calm | 422 -> `Unprocessable_entity + | 423 -> `Locked + | 424 -> `Failed_dependency + | 426 -> `Upgrade_required + | 428 -> `Precondition_required + | 429 -> `Too_many_requests + | 431 -> `Request_header_fields_too_large + | 444 -> `No_response + | 449 -> `Retry_with + | 450 -> `Blocked_by_windows_parental_controls + | 451 -> `Wrong_exchange_server + | 499 -> `Client_closed_request | 500 -> `Internal_server_error | 501 -> `Not_implemented | 502 -> `Bad_gateway | 503 -> `Service_unavailable - | 504 -> `Gateway_time_out - | 505 -> `HTTP_version_not_supported - | code -> `Code code + | 504 -> `Gateway_timeout + | 505 -> `Http_version_not_supported + | 506 -> `Variant_also_negotiates + | 507 -> `Insufficient_storage + | 508 -> `Loop_detected + | 509 -> `Bandwidth_limit_exceeded + | 510 -> `Not_extended + | 511 -> `Network_authentication_required + | 598 -> `Network_read_timeout_error + | 599 -> `Network_connect_timeout_error + | cod -> `Code cod -let code_of_status = function +let code_of_status: status_code -> int = function | `Continue -> 100 | `Switching_protocols -> 101 + | `Processing -> 102 + | `Checkpoint -> 103 | `OK -> 200 | `Created -> 201 | `Accepted -> 202 @@ -173,13 +210,18 @@ let code_of_status = function | `No_content -> 204 | `Reset_content -> 205 | `Partial_content -> 206 + | `Multi_status -> 207 + | `Already_reported -> 208 + | `Im_used -> 226 | `Multiple_choices -> 300 | `Moved_permanently -> 301 | `Found -> 302 | `See_other -> 303 | `Not_modified -> 304 | `Use_proxy -> 305 + | `Switch_proxy -> 306 | `Temporary_redirect -> 307 + | `Resume_incomplete -> 308 | `Bad_request -> 400 | `Unauthorized -> 401 | `Payment_required -> 402 @@ -188,42 +230,70 @@ let code_of_status = function | `Method_not_allowed -> 405 | `Not_acceptable -> 406 | `Proxy_authentication_required -> 407 - | `Request_time_out -> 408 + | `Request_timeout -> 408 | `Conflict -> 409 | `Gone -> 410 | `Length_required -> 411 | `Precondition_failed -> 412 | `Request_entity_too_large -> 413 - | `Request_URI_too_large -> 414 + | `Request_uri_too_long -> 414 | `Unsupported_media_type -> 415 | `Requested_range_not_satisfiable -> 416 | `Expectation_failed -> 417 + | `I_m_a_teapot -> 418 + | `Enhance_your_calm -> 420 | `Unprocessable_entity -> 422 + | `Locked -> 423 + | `Failed_dependency -> 424 + | `Upgrade_required -> 426 + | `Precondition_required -> 428 + | `Too_many_requests -> 429 + | `Request_header_fields_too_large -> 431 + | `No_response -> 444 + | `Retry_with -> 449 + | `Blocked_by_windows_parental_controls -> 450 + | `Wrong_exchange_server -> 451 + | `Client_closed_request -> 499 | `Internal_server_error -> 500 | `Not_implemented -> 501 | `Bad_gateway -> 502 | `Service_unavailable -> 503 - | `Gateway_time_out -> 504 - | `HTTP_version_not_supported -> 505 - | `Code code -> code + | `Gateway_timeout -> 504 + | `Http_version_not_supported -> 505 + | `Variant_also_negotiates -> 506 + | `Insufficient_storage -> 507 + | `Loop_detected -> 508 + | `Bandwidth_limit_exceeded -> 509 + | `Not_extended -> 510 + | `Network_authentication_required -> 511 + | `Network_read_timeout_error -> 598 + | `Network_connect_timeout_error -> 599 + | `Code cod -> cod -let string_of_status = function +let string_of_status: status_code -> string = function | `Continue -> "100 Continue" | `Switching_protocols -> "101 Switching Protocols" + | `Processing -> "102 Processing (WebDAV) (RFC 2518)" + | `Checkpoint -> "103 Checkpoint" | `OK -> "200 OK" | `Created -> "201 Created" | `Accepted -> "202 Accepted" - | `Non_authoritative_information -> "203 Non-authoritative Information" + | `Non_authoritative_information -> "203 Non-Authoritative Information (since HTTP/1.1)" | `No_content -> "204 No Content" | `Reset_content -> "205 Reset Content" | `Partial_content -> "206 Partial Content" + | `Multi_status -> "207 Multi-Status (WebDAV) (RFC 4918)" + | `Already_reported -> "208 Already Reported (WebDAV) (RFC 5842)" + | `Im_used -> "226 IM Used (RFC 3229)" | `Multiple_choices -> "300 Multiple Choices" | `Moved_permanently -> "301 Moved Permanently" | `Found -> "302 Found" | `See_other -> "303 See Other" | `Not_modified -> "304 Not Modified" - | `Use_proxy -> "305 Use Proxy" - | `Temporary_redirect -> "307 Temporary Redirect" + | `Use_proxy -> "305 Use Proxy (since HTTP/1.1)" + | `Switch_proxy -> "306 Switch Proxy" + | `Temporary_redirect -> "307 Temporary Redirect (since HTTP/1.1)" + | `Resume_incomplete -> "308 Resume Incomplete" | `Bad_request -> "400 Bad Request" | `Unauthorized -> "401 Unauthorized" | `Payment_required -> "402 Payment Required" @@ -232,92 +302,143 @@ let string_of_status = function | `Method_not_allowed -> "405 Method Not Allowed" | `Not_acceptable -> "406 Not Acceptable" | `Proxy_authentication_required -> "407 Proxy Authentication Required" - | `Request_time_out -> "408 Request Time Out" + | `Request_timeout -> "408 Request Timeout" | `Conflict -> "409 Conflict" | `Gone -> "410 Gone" | `Length_required -> "411 Length Required" | `Precondition_failed -> "412 Precondition Failed" | `Request_entity_too_large -> "413 Request Entity Too Large" - | `Request_URI_too_large -> "414 Request URI Too Large" + | `Request_uri_too_long -> "414 Request-URI Too Long" | `Unsupported_media_type -> "415 Unsupported Media Type" | `Requested_range_not_satisfiable -> "416 Requested Range Not Satisfiable" | `Expectation_failed -> "417 Expectation Failed" - | `Unprocessable_entity -> "422 Unprocessable Entity" + | `I_m_a_teapot -> "418 I'm a teapot (RFC 2324)" + | `Enhance_your_calm -> "420 Enhance Your Calm" + | `Unprocessable_entity -> "422 Unprocessable Entity (WebDAV) (RFC 4918)" + | `Locked -> "423 Locked (WebDAV) (RFC 4918)" + | `Failed_dependency -> "424 Failed Dependency (WebDAV) (RFC 4918)" + | `Upgrade_required -> "426 Upgrade Required (RFC 2817)" + | `Precondition_required -> "428 Precondition Required" + | `Too_many_requests -> "429 Too Many Requests" + | `Request_header_fields_too_large -> "431 Request Header Fields Too Large" + | `No_response -> "444 No Response" + | `Retry_with -> "449 Retry With" + | `Blocked_by_windows_parental_controls -> "450 Blocked by Windows Parental Controls" + | `Wrong_exchange_server -> "451 Wrong Exchange server" + | `Client_closed_request -> "499 Client Closed Request" | `Internal_server_error -> "500 Internal Server Error" | `Not_implemented -> "501 Not Implemented" | `Bad_gateway -> "502 Bad Gateway" | `Service_unavailable -> "503 Service Unavailable" - | `Gateway_time_out -> "504 Gateway Timeout" - | `HTTP_version_not_supported -> "505 HTTP Version Not Supported" - | `Code code -> string_of_int code + | `Gateway_timeout -> "504 Gateway Timeout" + | `Http_version_not_supported -> "505 HTTP Version Not Supported" + | `Variant_also_negotiates -> "506 Variant Also Negotiates (RFC 2295)" + | `Insufficient_storage -> "507 Insufficient Storage (WebDAV) (RFC 4918)" + | `Loop_detected -> "508 Loop Detected (WebDAV) (RFC 5842)" + | `Bandwidth_limit_exceeded -> "509 Bandwidth Limit Exceeded (Apache bw/limited extension)" + | `Not_extended -> "510 Not Extended (RFC 2774)" + | `Network_authentication_required -> "511 Network Authentication Required" + | `Network_read_timeout_error -> "598 Network read timeout error" + | `Network_connect_timeout_error -> "599 Network connect timeout error" + | `Code cod -> string_of_int cod -let reason_phrase_of_code = function +let reason_phrase_of_code: int -> string = function | 100 -> "Continue" - | 101 -> "Switching protocols" + | 101 -> "Switching Protocols" + | 102 -> "Processing (WebDAV) (RFC 2518)" + | 103 -> "Checkpoint" | 200 -> "OK" | 201 -> "Created" | 202 -> "Accepted" - | 203 -> "Non authoritative information" - | 204 -> "No content" - | 205 -> "Reset content" - | 206 -> "Partial content" - | 300 -> "Multiple choices" - | 301 -> "Moved permanently" + | 203 -> "Non-Authoritative Information (since HTTP/1.1)" + | 204 -> "No Content" + | 205 -> "Reset Content" + | 206 -> "Partial Content" + | 207 -> "Multi-Status (WebDAV) (RFC 4918)" + | 208 -> "Already Reported (WebDAV) (RFC 5842)" + | 226 -> "IM Used (RFC 3229)" + | 300 -> "Multiple Choices" + | 301 -> "Moved Permanently" | 302 -> "Found" - | 303 -> "See other" - | 304 -> "Not modified" - | 305 -> "Use proxy" - | 307 -> "Temporary redirect" - | 400 -> "Bad request" + | 303 -> "See Other" + | 304 -> "Not Modified" + | 305 -> "Use Proxy (since HTTP/1.1)" + | 306 -> "Switch Proxy" + | 307 -> "Temporary Redirect (since HTTP/1.1)" + | 308 -> "Resume Incomplete" + | 400 -> "Bad Request" | 401 -> "Unauthorized" - | 402 -> "Payment required" + | 402 -> "Payment Required" | 403 -> "Forbidden" - | 404 -> "Not found" - | 405 -> "Method not allowed" - | 406 -> "Not acceptable" - | 407 -> "Proxy authentication required" - | 408 -> "Request time out" + | 404 -> "Not Found" + | 405 -> "Method Not Allowed" + | 406 -> "Not Acceptable" + | 407 -> "Proxy Authentication Required" + | 408 -> "Request Timeout" | 409 -> "Conflict" | 410 -> "Gone" - | 411 -> "Length required" - | 412 -> "Precondition failed" - | 413 -> "Request entity too large" - | 414 -> "Request URI too large" - | 415 -> "Unsupported media type" - | 416 -> "Requested range not satisfiable" - | 417 -> "Expectation failed" - | 422 -> "Unprocessable entity" - | 500 -> "Internal server error" - | 501 -> "Not implemented" - | 502 -> "Bad gateway" - | 503 -> "Service unavailable" - | 504 -> "Gateway time out" - | 505 -> "HTTP version not supported" - | invalid_code -> string_of_int invalid_code + | 411 -> "Length Required" + | 412 -> "Precondition Failed" + | 413 -> "Request Entity Too Large" + | 414 -> "Request-URI Too Long" + | 415 -> "Unsupported Media Type" + | 416 -> "Requested Range Not Satisfiable" + | 417 -> "Expectation Failed" + | 418 -> "I'm a teapot (RFC 2324)" + | 420 -> "Enhance Your Calm" + | 422 -> "Unprocessable Entity (WebDAV) (RFC 4918)" + | 423 -> "Locked (WebDAV) (RFC 4918)" + | 424 -> "Failed Dependency (WebDAV) (RFC 4918)" + | 426 -> "Upgrade Required (RFC 2817)" + | 428 -> "Precondition Required" + | 429 -> "Too Many Requests" + | 431 -> "Request Header Fields Too Large" + | 444 -> "No Response" + | 449 -> "Retry With" + | 450 -> "Blocked by Windows Parental Controls" + | 451 -> "Wrong Exchange server" + | 499 -> "Client Closed Request" + | 500 -> "Internal Server Error" + | 501 -> "Not Implemented" + | 502 -> "Bad Gateway" + | 503 -> "Service Unavailable" + | 504 -> "Gateway Timeout" + | 505 -> "HTTP Version Not Supported" + | 506 -> "Variant Also Negotiates (RFC 2295)" + | 507 -> "Insufficient Storage (WebDAV) (RFC 4918)" + | 508 -> "Loop Detected (WebDAV) (RFC 5842)" + | 509 -> "Bandwidth Limit Exceeded (Apache bw/limited extension)" + | 510 -> "Not Extended (RFC 2774)" + | 511 -> "Network Authentication Required" + | 598 -> "Network read timeout error" + | 599 -> "Network connect timeout error" + | cod -> string_of_int cod let is_informational code = match status_of_code code with | #informational_status -> true - | _ -> false + | _ -> false let is_success code = match status_of_code code with | #success_status -> true - | _ -> false + | _ -> false let is_redirection code = match status_of_code code with | #redirection_status -> true - | _ -> false + | _ -> false let is_client_error code = match status_of_code code with | #client_error_status -> true - | _ -> false + | _ -> false let is_server_error code = match status_of_code code with | #server_error_status -> true - | _ -> false + | _ -> false + let is_error code = is_client_error code || is_server_error code + diff --git a/cohttp/code.mli b/cohttp/code.mli index cc39b13a9e..352c9f6d0e 100644 --- a/cohttp/code.mli +++ b/cohttp/code.mli @@ -1,81 +1,98 @@ -(* - OCaml HTTP - do it yourself (fully OCaml) HTTP daemon - - Copyright (C) <2002-2005> Stefano Zacchiroli - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU Library General Public License as - published by the Free Software Foundation, version 2. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 - USA -*) +(* Auto-Generated by 'ocaml generate.ml' *) type version = [ `HTTP_1_0 | `HTTP_1_1 ] + type meth = [ `GET | `POST | `HEAD | `DELETE | `PATCH | `PUT | `OPTIONS ] type informational_status = - [ `Continue - | `Switching_protocols + [ `Continue (** Client should continue with request *) + | `Switching_protocols (** Server is switching protocols *) + | `Processing (** Server has received and is processing the request *) + | `Checkpoint (** resume aborted PUT or POST requests *) ] +(** Informational *) + type success_status = - [ `OK - | `Created - | `Accepted - | `Non_authoritative_information - | `No_content - | `Reset_content - | `Partial_content + [ `OK (** standard response for successful HTTP requests *) + | `Created (** request has been fulfilled; new resource created *) + | `Accepted (** request accepted, processing pending *) + | `Non_authoritative_information (** request processed, information may be from another source *) + | `No_content (** request processed, no content returned *) + | `Reset_content (** request processed, no content returned, reset document view *) + | `Partial_content (** partial resource return due to request header *) + | `Multi_status (** XML, can contain multiple separate responses *) + | `Already_reported (** results previously returned *) + | `Im_used (** request fulfilled, reponse is instance-manipulations *) ] +(** Success *) + type redirection_status = - [ `Multiple_choices - | `Moved_permanently - | `Found - | `See_other - | `Not_modified - | `Use_proxy - | `Temporary_redirect + [ `Multiple_choices (** multiple options for the resource delivered *) + | `Moved_permanently (** this and all future requests directed to the given URI *) + | `Found (** temporary response to request found via alternative URI *) + | `See_other (** permanent response to request found via alternative URI *) + | `Not_modified (** resource has not been modified since last requested *) + | `Use_proxy (** content located elsewhere, retrieve from there *) + | `Switch_proxy (** subsequent requests should use the specified proxy *) + | `Temporary_redirect (** connect again to different URI as provided *) + | `Resume_incomplete (** resumable HTTP requests *) ] +(** Redirection *) + type client_error_status = - [ `Bad_request - | `Unauthorized - | `Payment_required - | `Forbidden - | `Not_found - | `Method_not_allowed - | `Not_acceptable - | `Proxy_authentication_required - | `Request_time_out - | `Conflict - | `Gone - | `Length_required - | `Precondition_failed - | `Request_entity_too_large - | `Request_URI_too_large - | `Unsupported_media_type - | `Requested_range_not_satisfiable - | `Expectation_failed - | `Unprocessable_entity + [ `Bad_request (** request cannot be fulfilled due to bad syntax *) + | `Unauthorized (** authentication is possible but has failed *) + | `Payment_required (** payment required, reserved for future use *) + | `Forbidden (** server refuses to respond to request *) + | `Not_found (** requested resource could not be found *) + | `Method_not_allowed (** request method not supported by that resource *) + | `Not_acceptable (** content not acceptable according to the Accept headers *) + | `Proxy_authentication_required (** client must first authenticate itself with the proxy *) + | `Request_timeout (** server timed out waiting for the request *) + | `Conflict (** request could not be processed because of conflict *) + | `Gone (** resource is no longer available and will not be available again *) + | `Length_required (** request did not specify the length of its content *) + | `Precondition_failed (** server does not meet request preconditions *) + | `Request_entity_too_large (** request is larger than the server is willing or able to process *) + | `Request_uri_too_long (** URI provided was too long for the server to process *) + | `Unsupported_media_type (** server does not support media type *) + | `Requested_range_not_satisfiable (** client has asked for unprovidable portion of the file *) + | `Expectation_failed (** server cannot meet requirements of Expect request-header field *) + | `I_m_a_teapot (** I'm a teapot *) + | `Enhance_your_calm (** Twitter rate limiting *) + | `Unprocessable_entity (** request unable to be followed due to semantic errors *) + | `Locked (** resource that is being accessed is locked *) + | `Failed_dependency (** request failed due to failure of a previous request *) + | `Upgrade_required (** client should switch to a different protocol *) + | `Precondition_required (** origin server requires the request to be conditional *) + | `Too_many_requests (** user has sent too many requests in a given amount of time *) + | `Request_header_fields_too_large (** server is unwilling to process the request *) + | `No_response (** server returns no information and closes the connection *) + | `Retry_with (** request should be retried after performing action *) + | `Blocked_by_windows_parental_controls (** Windows Parental Controls blocking access to webpage *) + | `Wrong_exchange_server (** The server cannot reach the client's mailbox. *) + | `Client_closed_request (** connection closed by client while HTTP server is processing *) ] +(** Client_error *) + type server_error_status = - [ `Internal_server_error - | `Not_implemented - | `Bad_gateway - | `Service_unavailable - | `Gateway_time_out - | `HTTP_version_not_supported - ] -type error_status = - [ client_error_status - | server_error_status + [ `Internal_server_error (** generic error message *) + | `Not_implemented (** server does not recognise method or lacks ability to fulfill *) + | `Bad_gateway (** server received an invalid response from upstream server *) + | `Service_unavailable (** server is currently unavailable *) + | `Gateway_timeout (** gateway did not receive response from upstream server *) + | `Http_version_not_supported (** server does not support the HTTP protocol version *) + | `Variant_also_negotiates (** content negotiation for the request results in a circular reference *) + | `Insufficient_storage (** server is unable to store the representation *) + | `Loop_detected (** server detected an infinite loop while processing the request *) + | `Bandwidth_limit_exceeded (** bandwidth limit exceeded *) + | `Not_extended (** further extensions to the request are required *) + | `Network_authentication_required (** client needs to authenticate to gain network access *) + | `Network_read_timeout_error (** network read timeout behind the proxy *) + | `Network_connect_timeout_error (** network connect timeout behind the proxy *) ] +(** Server_error *) + type status = [ informational_status | success_status @@ -84,52 +101,50 @@ type status = | server_error_status ] -type status_code = [ `Code of int | status ] +type status_code = [`Code of int | status ] - (** pretty print an HTTP version *) val string_of_version: version -> string +(** Convert a version to a string. *) - (** parse an HTTP version from a string - @raise Invalid_HTTP_version if given string doesn't represent a supported HTTP - version *) val version_of_string: string -> version option +(** Convert a string to a version. Return [None] if the conversion fails. *) + - (** pretty print an HTTP method *) val string_of_method: meth -> string +(** Convert a method to a string. *) - (** parse an HTTP method from a string - @raise Invalid_HTTP_method if given string doesn't represent a supported - method *) val method_of_string: string -> meth option +(** Convert a string to a method. Return [None] if the conversion fails. *) + - (** converts an integer HTTP status to the corresponding status value - @raise Invalid_code if given integer isn't a valid HTTP status code *) val status_of_code: int -> status_code +(** Generate status values from int codes. *) - (** converts an HTTP status to the corresponding integer value *) val code_of_status: status_code -> int +(** Generate an int code from a status value. *) - (** converts an HTTP status to a human-readable string value *) val string_of_status: status_code -> string +(** Give a description of the given status value. *) - (** converts an HTTP status to the corresponding RFC reason phrase *) val reason_phrase_of_code: int -> string +(** Give a description of the given int code. *) - (** @return true on "informational" status codes, false elsewhere *) val is_informational: int -> bool +(** Is the given int code belong to the class of "informational" return code ? *) - (** @return true on "success" status codes, false elsewhere *) val is_success: int -> bool +(** Is the given int code belong to the class of "success" return code ? *) - (** @return true on "redirection" status codes, false elsewhere *) val is_redirection: int -> bool +(** Is the given int code belong to the class of "redirection" return code ? *) - (** @return true on "client error" status codes, false elsewhere *) val is_client_error: int -> bool +(** Is the given int code belong to the class of "client_error" return code ? *) - (** @return true on "server error" status codes, false elsewhere *) val is_server_error: int -> bool +(** Is the given int code belong to the class of "server_error" return code ? *) + - (** @return true on "client error" and "server error" status code, false - elsewhere *) val is_error: int -> bool +(** Return true for client and server error status codes. *) + diff --git a/cohttp/cohttp.mllib b/cohttp/cohttp.mllib new file mode 100644 index 0000000000..0970dcbc62 --- /dev/null +++ b/cohttp/cohttp.mllib @@ -0,0 +1,4 @@ +# OASIS_START +# DO NOT EDIT (digest: 4dcbd27e3e168ea645935020ff625c1e) +Cohttp +# OASIS_STOP diff --git a/cohttp/response.ml b/cohttp/response.ml index 94103972d9..08b8d543af 100644 --- a/cohttp/response.ml +++ b/cohttp/response.ml @@ -20,11 +20,12 @@ type t = { headers: Header.t; version: Code.version; status: Code.status_code; + flush: bool; } with fields -let make ?(version=`HTTP_1_1) ?(status=`OK) ?(encoding=Transfer.Chunked) ?headers () = +let make ?(version=`HTTP_1_1) ?(status=`OK) ?(flush=false) ?(encoding=Transfer.Chunked) ?headers () = let headers = match headers with None -> Header.init () |Some h -> h in - { encoding; headers; version; status } + { encoding; headers; version; flush; status } module type S = sig module IO : IO.S @@ -73,7 +74,8 @@ module Make(IO : IO.S) = struct |Some (version, status) -> Header_IO.parse ic >>= fun headers -> let encoding = Header.get_transfer_encoding headers in - return (Some { encoding; headers; version; status }) + let flush = false in + return (Some { encoding; headers; version; status; flush }) let has_body {encoding} = Transfer.has_body encoding let read_body_chunk {encoding} ic = Transfer_IO.read encoding ic diff --git a/cohttp/response.mli b/cohttp/response.mli index 7beae082e1..b77aade878 100644 --- a/cohttp/response.mli +++ b/cohttp/response.mli @@ -20,6 +20,7 @@ type t = { headers: Header.t; version: Code.version; status: Code.status_code; + flush: bool; } with fields (** Retrieve response HTTP headers *) @@ -37,6 +38,7 @@ val status : t -> Code.status_code val make : ?version:Code.version -> ?status:Code.status_code -> + ?flush:bool -> ?encoding:Transfer.encoding -> ?headers:Header.t -> unit -> t diff --git a/lib_test/README.md b/lib_test/README.md new file mode 100644 index 0000000000..246258e609 --- /dev/null +++ b/lib_test/README.md @@ -0,0 +1,11 @@ +The Server Side Events example here is lifted from the HTML5 Doctor, which is +under the Apache 2 license at: + +To run it, build the test cases in the main repository and then: + +* `cd lib_test` +* env COHTTP_DEBUG=1 ../_build/lib_test/test_net_lwt_server.native +* Browse to + +You should be able to see the timestamp printing to the server +console and reflecting on the clock on the webpage. Magic! diff --git a/lib_test/coolclock.js b/lib_test/coolclock.js new file mode 100644 index 0000000000..ddd58b3dad --- /dev/null +++ b/lib_test/coolclock.js @@ -0,0 +1,318 @@ +/** + * CoolClock 2.1.4 + * Copyright 2010, Simon Baird + * Released under the BSD License. + * + * Display an analog clock using canvas. + * http://randomibis.com/coolclock/ + * + */ + +// Constructor for CoolClock objects +window.CoolClock = function(options) { + return this.init(options); +} + +// Config contains some defaults, and clock skins +CoolClock.config = { + tickDelay: 1000, + longTickDelay: 15000, + defaultRadius: 85, + renderRadius: 100, + defaultSkin: "swissRail", + // Should be in skin probably... + // (TODO: allow skinning of digital display) + showSecs: true, + showAmPm: true, + + skins: { + // There are more skins in moreskins.js + // Try making your own skin by copy/pasting one of these and tweaking it + swissRail: { + outerBorder: { lineWidth: 2, radius:95, color: "black", alpha: 1 }, + smallIndicator: { lineWidth: 2, startAt: 88, endAt: 92, color: "black", alpha: 1 }, + largeIndicator: { lineWidth: 4, startAt: 79, endAt: 92, color: "black", alpha: 1 }, + hourHand: { lineWidth: 8, startAt: -15, endAt: 50, color: "black", alpha: 1 }, + minuteHand: { lineWidth: 7, startAt: -15, endAt: 75, color: "black", alpha: 1 }, + secondHand: { lineWidth: 1, startAt: -20, endAt: 85, color: "red", alpha: 1 }, + secondDecoration: { lineWidth: 1, startAt: 70, radius: 4, fillColor: "red", color: "red", alpha: 1 } + }, + chunkySwiss: { + outerBorder: { lineWidth: 4, radius:97, color: "black", alpha: 1 }, + smallIndicator: { lineWidth: 4, startAt: 89, endAt: 93, color: "black", alpha: 1 }, + largeIndicator: { lineWidth: 8, startAt: 80, endAt: 93, color: "black", alpha: 1 }, + hourHand: { lineWidth: 12, startAt: -15, endAt: 60, color: "black", alpha: 1 }, + minuteHand: { lineWidth: 10, startAt: -15, endAt: 85, color: "black", alpha: 1 }, + secondHand: { lineWidth: 4, startAt: -20, endAt: 85, color: "red", alpha: 1 }, + secondDecoration: { lineWidth: 2, startAt: 70, radius: 8, fillColor: "red", color: "red", alpha: 1 } + }, + chunkySwissOnBlack: { + outerBorder: { lineWidth: 4, radius:97, color: "white", alpha: 1 }, + smallIndicator: { lineWidth: 4, startAt: 89, endAt: 93, color: "white", alpha: 1 }, + largeIndicator: { lineWidth: 8, startAt: 80, endAt: 93, color: "white", alpha: 1 }, + hourHand: { lineWidth: 12, startAt: -15, endAt: 60, color: "white", alpha: 1 }, + minuteHand: { lineWidth: 10, startAt: -15, endAt: 85, color: "white", alpha: 1 }, + secondHand: { lineWidth: 4, startAt: -20, endAt: 85, color: "red", alpha: 1 }, + secondDecoration: { lineWidth: 2, startAt: 70, radius: 8, fillColor: "red", color: "red", alpha: 1 } + } + + }, + + // Test for IE so we can nurse excanvas in a couple of places + isIE: !!document.all, + + // Will store (a reference to) each clock here, indexed by the id of the canvas element + clockTracker: {}, + + // For giving a unique id to coolclock canvases with no id + noIdCount: 0 +}; + +// Define the CoolClock object's methods +CoolClock.prototype = { + + // Initialise using the parameters parsed from the colon delimited class + init: function(options) { + // Parse and store the options + this.canvasId = options.canvasId; + this.skinId = options.skinId || CoolClock.config.defaultSkin; + this.displayRadius = options.displayRadius || CoolClock.config.defaultRadius; + this.showSecondHand = typeof options.showSecondHand == "boolean" ? options.showSecondHand : true; + this.gmtOffset = (options.gmtOffset != null && options.gmtOffset != '') ? parseFloat(options.gmtOffset) : null; + this.showDigital = typeof options.showDigital == "boolean" ? options.showDigital : false; + this.logClock = typeof options.logClock == "boolean" ? options.logClock : false; + this.logClockRev = typeof options.logClock == "boolean" ? options.logClockRev : false; + + this.tickDelay = CoolClock.config[ this.showSecondHand ? "tickDelay" : "longTickDelay" ]; + + // Get the canvas element + this.canvas = document.getElementById(this.canvasId); + + // Make the canvas the requested size. It's always square. + this.canvas.setAttribute("width",this.displayRadius*2); + this.canvas.setAttribute("height",this.displayRadius*2); + this.canvas.style.width = this.displayRadius*2 + "px"; + this.canvas.style.height = this.displayRadius*2 + "px"; + + // Explain me please...? + this.renderRadius = CoolClock.config.renderRadius; + this.scale = this.displayRadius / this.renderRadius; + + // Initialise canvas context + this.ctx = this.canvas.getContext("2d"); + this.ctx.scale(this.scale,this.scale); + + // Keep track of this object + CoolClock.config.clockTracker[this.canvasId] = this; + + // Start the clock going + //this.tick(); + + return this; + }, + + // Draw a circle at point x,y with params as defined in skin + fullCircleAt: function(x,y,skin) { + this.ctx.save(); + this.ctx.globalAlpha = skin.alpha; + this.ctx.lineWidth = skin.lineWidth; + + if (!CoolClock.config.isIE) { + this.ctx.beginPath(); + } + + if (CoolClock.config.isIE) { + // excanvas doesn't scale line width so we will do it here + this.ctx.lineWidth = this.ctx.lineWidth * this.scale; + } + + this.ctx.arc(x, y, skin.radius, 0, 2*Math.PI, false); + + if (CoolClock.config.isIE) { + // excanvas doesn't close the circle so let's fill in the tiny gap + this.ctx.arc(x, y, skin.radius, -0.1, 0.1, false); + } + + if (skin.fillColor) { + this.ctx.fillStyle = skin.fillColor + this.ctx.fill(); + } + else { + // XXX why not stroke and fill + this.ctx.strokeStyle = skin.color; + this.ctx.stroke(); + } + this.ctx.restore(); + }, + + // Draw some text centered vertically and horizontally + drawTextAt: function(theText,x,y) { + this.ctx.save(); + this.ctx.font = '15px sans-serif'; + var tSize = this.ctx.measureText(theText); + if (!tSize.height) tSize.height = 15; // no height in firefox.. :( + this.ctx.fillText(theText,x - tSize.width/2,y - tSize.height/2); + this.ctx.restore(); + }, + + lpad2: function(num) { + return (num < 10 ? '0' : '') + num; + }, + + tickAngle: function(second) { + // Log algorithm by David Bradshaw + var tweak = 3; // If it's lower the one second mark looks wrong (?) + if (this.logClock) { + return second == 0 ? 0 : (Math.log(second*tweak) / Math.log(60*tweak)); + } + else if (this.logClockRev) { + // Flip the seconds then flip the angle (trickiness) + second = (60 - second) % 60; + return 1.0 - (second == 0 ? 0 : (Math.log(second*tweak) / Math.log(60*tweak))); + } + else { + return second/60.0; + } + }, + + timeText: function(hour,min,sec) { + var c = CoolClock.config; + return '' + + (c.showAmPm ? ((hour%12)==0 ? 12 : (hour%12)) : hour) + ':' + + this.lpad2(min) + + (c.showSecs ? ':' + this.lpad2(sec) : '') + + (c.showAmPm ? (hour < 12 ? ' am' : ' pm') : '') + ; + }, + + // Draw a radial line by rotating then drawing a straight line + // Ha ha, I think I've accidentally used Taus, (see http://tauday.com/) + radialLineAtAngle: function(angleFraction,skin) { + this.ctx.save(); + this.ctx.translate(this.renderRadius,this.renderRadius); + this.ctx.rotate(Math.PI * (2.0 * angleFraction - 0.5)); + this.ctx.globalAlpha = skin.alpha; + this.ctx.strokeStyle = skin.color; + this.ctx.lineWidth = skin.lineWidth; + + if (CoolClock.config.isIE) + // excanvas doesn't scale line width so we will do it here + this.ctx.lineWidth = this.ctx.lineWidth * this.scale; + + if (skin.radius) { + this.fullCircleAt(skin.startAt,0,skin) + } + else { + this.ctx.beginPath(); + this.ctx.moveTo(skin.startAt,0) + this.ctx.lineTo(skin.endAt,0); + this.ctx.stroke(); + } + this.ctx.restore(); + }, + + render: function(hour,min,sec) { + // Get the skin + var skin = CoolClock.config.skins[this.skinId]; + if (!skin) skin = CoolClock.config.skins[CoolClock.config.defaultSkin]; + + // Clear + this.ctx.clearRect(0,0,this.renderRadius*2,this.renderRadius*2); + + // Draw the outer edge of the clock + if (skin.outerBorder) + this.fullCircleAt(this.renderRadius,this.renderRadius,skin.outerBorder); + + // Draw the tick marks. Every 5th one is a big one + for (var i=0;i<60;i++) { + (i%5) && skin.smallIndicator && this.radialLineAtAngle(this.tickAngle(i),skin.smallIndicator); + !(i%5) && skin.largeIndicator && this.radialLineAtAngle(this.tickAngle(i),skin.largeIndicator); + } + + // Write the time + if (this.showDigital) { + this.drawTextAt( + this.timeText(hour,min,sec), + this.renderRadius, + this.renderRadius+this.renderRadius/2 + ); + } + + // Draw the hands + if (skin.hourHand) + this.radialLineAtAngle(this.tickAngle(((hour%12)*5 + min/12.0)),skin.hourHand); + + if (skin.minuteHand) + this.radialLineAtAngle(this.tickAngle((min + sec/60.0)),skin.minuteHand); + + if (this.showSecondHand && skin.secondHand) + this.radialLineAtAngle(this.tickAngle(sec),skin.secondHand); + + // Second hand decoration doesn't render right in IE so lets turn it off + if (!CoolClock.config.isIE && this.showSecondHand && skin.secondDecoration) + this.radialLineAtAngle(this.tickAngle(sec),skin.secondDecoration); + }, + + // Check the time and display the clock + refreshDisplay: function() { + var now = new Date(); + if (this.gmtOffset != null) { + // Use GMT + gmtOffset + var offsetNow = new Date(now.valueOf() + (this.gmtOffset * 1000 * 60 * 60)); + this.render(offsetNow.getUTCHours(),offsetNow.getUTCMinutes(),offsetNow.getUTCSeconds()); + } + else { + // Use local time + this.render(now.getHours(),now.getMinutes(),now.getSeconds()); + } + }, + + // Set timeout to trigger a tick in the future + nextTick: function() { + setTimeout("CoolClock.config.clockTracker['"+this.canvasId+"'].tick()",this.tickDelay); + }, + + // Check the canvas element hasn't been removed + stillHere: function() { + return document.getElementById(this.canvasId) != null; + }, + + // Main tick handler. Refresh the clock then setup the next tick + tick: function() { + if (this.stillHere()) { + this.refreshDisplay() + this.nextTick(); + } + } +}; + +// Find all canvas elements that have the CoolClock class and turns them into clocks +CoolClock.findAndCreateClocks = function() { + // (Let's not use a jQuery selector here so it's easier to use frameworks other than jQuery) + var canvases = document.getElementsByTagName("canvas"); + for (var i=0;i +// If you do have jQuery and it's loaded already then we can do it right now +if (window.jQuery) jQuery(document).ready(CoolClock.findAndCreateClocks); \ No newline at end of file diff --git a/lib_test/sse.html b/lib_test/sse.html new file mode 100644 index 0000000000..fc6032e538 --- /dev/null +++ b/lib_test/sse.html @@ -0,0 +1,239 @@ + + + + + +HTML5 Server-Sent Test + + + + +

    + + + Connecting...

    +

    +
    +
    The clock before is implemented using HTML5 <canvas> and +Server-Sent Events. +The server's time is pushed to the client every 5 seconds using a single open connection. +The server is set to break connections lasting longer than 10 seconds. However, the browser +automatically reconnects SSEs ~3 seconds after dropped connections!
    + +
    + + + + + diff --git a/lib_test/test_net_lwt_server.ml b/lib_test/test_net_lwt_server.ml index 9f33bac0d3..4c05eb0b62 100644 --- a/lib_test/test_net_lwt_server.ml +++ b/lib_test/test_net_lwt_server.ml @@ -24,7 +24,9 @@ open Cohttp_lwt_unix let make_server () = let callback conn_id ?body req = - match Uri.path (Request.uri req) with + let uri = Request.uri req in + Printf.printf "%s\n%!" (Uri.to_string uri); + match Uri.path uri with |""|"/" -> Server.respond_string ~status:`OK ~body:"helloworld" () |"/post" -> begin lwt body = Cohttp_lwt_body.string_of_body body in @@ -33,6 +35,44 @@ let make_server () = |"/postnodrain" -> begin Server.respond_string ~status:`OK ~body:"nodrain" () end + |"/sse.php" -> begin + let headers = Header.init_with "content-type" "text/event-stream" in + let headers = Header.add headers "cache-control" "no-cache" in + let st,push_st = Lwt_stream.create () in + let body = Cohttp_lwt_body.body_of_stream st in + let cur_time () = + let tod = Unix.gettimeofday () in + let tm = Unix.localtime tod in + let s = Unix.(sprintf "%d:%d:%d" tm.tm_hour tm.tm_min tm.tm_sec) in + let id = int_of_float (Unix.gettimeofday ()) in + s,id + in + let _, start_time = cur_time () in + let send_msg id msg = + let msgs = [ + "data: {"; + sprintf "data: \"msg\": \"%d\"," msg; + sprintf "data: \"id\": %d" id; + "data: }" ] in + let r = sprintf "id: %d\r\n%s\r\n\r\n" id (String.concat "\r\n" msgs) in + Some r + in + let _ = + try_lwt + let rec respond () = + let pp,time = cur_time () in + print_endline pp; + (if time - start_time > 10 then + push_st None + else + push_st (send_msg start_time time)); + Lwt_unix.sleep 3.0 + >>= respond + in respond () + with exn -> return () + in + Server.respond ~headers ~flush:true ~status:`OK ~body () + end |_ -> let fname = Server.resolve_file ~docroot:"." ~uri:(Request.uri req) in Server.respond_file ~fname () diff --git a/lib_test/test_net_mirage_server.ml b/lib_test/test_net_mirage_server.ml index e891c86c1b..6c5aca5e9f 100644 --- a/lib_test/test_net_mirage_server.ml +++ b/lib_test/test_net_mirage_server.ml @@ -18,7 +18,7 @@ open OUnit open Printf open Lwt -open Cohttp_lwt_mirage +open Cohttp_mirage let ip = let open Net.Nettypes in @@ -40,5 +40,5 @@ let make_server () = Net.Manager.configure interface (`IPv4 ip) >>= fun () -> Server.listen mgr src spec ) - -let _ = OS.Main.run (make_server ()) + +let _ = OS.Main.run (make_server ()) diff --git a/lwt/cohttp_lwt.ml b/lwt/cohttp_lwt.ml index 9fb5668b5a..91583af87a 100644 --- a/lwt/cohttp_lwt.ml +++ b/lwt/cohttp_lwt.ml @@ -116,22 +116,22 @@ module Make_client match_lwt Response.read ic with |None -> return None |Some res -> begin - match Response.has_body res with - |true -> - let stream = Cohttp_lwt_body.create_stream (Response.read_body_chunk res) ic in - (match closefn with - |Some fn -> + match Response.has_body res with + |true -> + let stream = Cohttp_lwt_body.create_stream (Response.read_body_chunk res) ic in + (match closefn with + |Some fn -> Lwt_stream.on_terminate stream fn; let gcfn st = fn () in Gc.finalise gcfn stream - |None -> () - ); - let body = Cohttp_lwt_body.body_of_stream stream in - return (Some (res, body)) - |false -> - (match closefn with |Some fn -> fn () |None -> ()); - return (Some (res, None)) - end + |None -> () + ); + let body = Cohttp_lwt_body.body_of_stream stream in + return (Some (res, body)) + |false -> + (match closefn with |Some fn -> fn () |None -> ()); + return (Some (res, None)) + end let call ?headers ?(body:Cohttp_lwt_body.t) ?(chunked=true) meth uri = let headers = match headers with None -> Header.init () | Some h -> h in @@ -139,19 +139,19 @@ module Make_client let closefn () = Net.close ic oc in match chunked with | true -> - let req = Request.make_for_client ~headers ~chunked meth uri in - Request.write (fun req oc -> + let req = Request.make_for_client ~headers ~chunked meth uri in + Request.write (fun req oc -> Cohttp_lwt_body.write_body (Request.write_body req oc) body) req oc - >>= fun () -> - read_response ~closefn ic oc + >>= fun () -> + read_response ~closefn ic oc | false -> - (* If chunked is not allowed, then obtain the body length and insert header *) - lwt (body_length, buf) = Cohttp_lwt_body.get_length body in - let req = Request.make_for_client ~headers ~chunked ~body_length meth uri in - Request.write (fun req oc -> + (* If chunked is not allowed, then obtain the body length and insert header *) + lwt (body_length, buf) = Cohttp_lwt_body.get_length body in + let req = Request.make_for_client ~headers ~chunked ~body_length meth uri in + Request.write (fun req oc -> Cohttp_lwt_body.write_body (Request.write_body req oc) buf) req oc - >>= fun () -> - read_response ~closefn ic oc + >>= fun () -> + read_response ~closefn ic oc (* The HEAD should not have a response body *) let head ?headers uri = @@ -177,17 +177,17 @@ module Make_client lwt (ic, oc) = Net.connect ~ssl ~host ~service () in (* Serialise the requests out to the wire *) let _ = Lwt_stream.iter_s (fun (req,body) -> - Request.write (fun req oc -> - Cohttp_lwt_body.write_body (Request.write_body req oc) body) req oc) - reqs in + Request.write (fun req oc -> + Cohttp_lwt_body.write_body (Request.write_body req oc) body) req oc) + reqs in (* Read the responses. For each response, ensure that the previous response * has consumed the body before continuing to the next response, since HTTP/1.1 * pipelining cannot be interleaved. *) let read_m = Lwt_mutex.create () in let resps = Lwt_stream.from (fun () -> - let closefn () = Lwt_mutex.unlock read_m in - Lwt_mutex.with_lock read_m (fun () -> read_response ~closefn ic oc) - ) in + let closefn () = Lwt_mutex.unlock read_m in + Lwt_mutex.with_lock read_m (fun () -> read_response ~closefn ic oc) + ) in Lwt_stream.on_terminate resps (fun () -> Net.close ic oc); return resps end @@ -207,6 +207,7 @@ module type Server = sig module IO : IO.S module Request : Request module Response : Response + type t = server = { callback : Cohttp.Connection.t -> @@ -219,6 +220,7 @@ module type Server = sig val respond : ?headers:Cohttp.Header.t -> + ?flush:bool -> status:Cohttp.Code.status_code -> body:Cohttp_lwt_body.t -> unit -> (Cohttp.Response.t * Cohttp_lwt_body.t) Lwt.t @@ -247,12 +249,13 @@ end module Make_server(IO:Cohttp.IO.S with type 'a t = 'a Lwt.t) - (Request:Request with module IO=IO) - (Response:Response with module IO=IO) - (Net:Net with module IO=IO) = struct + (Request:Request with module IO=IO) + (Response:Response with module IO=IO) + (Net:Net with module IO=IO) = struct module IO = IO module Request = Request module Response = Response + type t = server = { callback : Cohttp.Connection.t -> @@ -265,14 +268,14 @@ module Make_server(IO:Cohttp.IO.S with type 'a t = 'a Lwt.t) module Transfer_IO = Transfer_io.Make(IO) - let respond ?headers ~status ~body () = + let respond ?headers ?(flush=false) ~status ~body () = let encoding = Cohttp_lwt_body.get_transfer_encoding body in - let res = Response.make ~status ~encoding ?headers () in + let res = Response.make ~status ~flush ~encoding ?headers () in return (res, body) let respond_string ?headers ~status ~body () = let res = Response.make ~status - ~encoding:(Transfer.Fixed (String.length body)) ?headers () in + ~encoding:(Transfer.Fixed (String.length body)) ?headers () in let body = Cohttp_lwt_body.body_of_string body in return (res,body) @@ -294,8 +297,8 @@ module Make_server(IO:Cohttp.IO.S with type 'a t = 'a Lwt.t) let respond_not_found ?uri () = let body = match uri with - |None -> "Not found" - |Some uri -> "Not found: " ^ (Uri.to_string uri) in + |None -> "Not found" + |Some uri -> "Not found: " ^ (Uri.to_string uri) in respond_string ~status:`Not_found ~body () let callback spec = @@ -306,45 +309,53 @@ module Make_server(IO:Cohttp.IO.S with type 'a t = 'a Lwt.t) considered closed after the first request/response. *) let early_close = ref false in (* Read the requests *) - let req_stream = Lwt_stream.from (fun () -> - if !early_close - then return None - else - lwt () = Lwt_mutex.lock read_m in - match_lwt Request.read ic with - |None -> - Lwt_mutex.unlock read_m; - return None - |Some req -> begin - early_close := Request.version req = `HTTP_1_0; - (* Ensure the input body has been fully read before reading again *) - match Request.has_body req with - |true -> - let body_stream = Cohttp_lwt_body.create_stream (Request.read_body_chunk req) ic in - Lwt_stream.on_terminate body_stream (fun () -> Lwt_mutex.unlock read_m); - let body = Cohttp_lwt_body.body_of_stream body_stream in - (* The read_m remains locked until the caller reads the body *) - return (Some (req, body)) - |false -> + let req_stream = Lwt_stream.from ( + fun () -> + if !early_close + then return None + else + lwt () = Lwt_mutex.lock read_m in + match_lwt Request.read ic with + | None -> Lwt_mutex.unlock read_m; - return (Some (req, None)) - end - ) in + return None + | Some req -> begin + early_close := Request.version req = `HTTP_1_0; + (* Ensure the input body has been fully read before reading again *) + match Request.has_body req with + | true -> + let body_stream = Cohttp_lwt_body.create_stream (Request.read_body_chunk req) ic in + Lwt_stream.on_terminate body_stream (fun () -> Lwt_mutex.unlock read_m); + let body = Cohttp_lwt_body.body_of_stream body_stream in + (* The read_m remains locked until the caller reads the body *) + return (Some (req, body)) + | false -> + Lwt_mutex.unlock read_m; + return (Some (req, None)) + end + ) in (* Map the requests onto a response stream to serialise out *) - let res_stream = Lwt_stream.map_s (fun (req, body) -> - try_lwt - spec.callback conn_id ?body req - with exn -> - respond_error ~status:`Internal_server_error ~body:(Printexc.to_string exn) () - finally Cohttp_lwt_body.drain_body body - ) req_stream in + let res_stream = + Lwt_stream.map_s (fun (req, body) -> + try_lwt + spec.callback conn_id ?body req + with exn -> + respond_error ~status:`Internal_server_error ~body:(Printexc.to_string exn) () + finally Cohttp_lwt_body.drain_body body + ) req_stream in (* Clean up resources when the response stream terminates and call * the user callback *) Lwt_stream.on_terminate res_stream (spec.conn_closed conn_id); (* Transmit the responses *) for_lwt (res,body) in res_stream do + let flush = + if res.Response.flush then + fun () -> IO.flush oc + else + fun () -> return_unit + in Response.write (fun res oc -> - Cohttp_lwt_body.write_body (Response.write_body res oc) body + Cohttp_lwt_body.write_body ~flush (Response.write_body res oc) body ) res oc done in daemon_callback diff --git a/lwt/cohttp_lwt.mli b/lwt/cohttp_lwt.mli index c3fc3e0fbb..722f7da9dd 100644 --- a/lwt/cohttp_lwt.mli +++ b/lwt/cohttp_lwt.mli @@ -19,7 +19,7 @@ open Cohttp (** Portable Lwt implementation of HTTP client and server, without depending on a particular I/O implementation. The various [Make] - functors must be instantiated by an implmentation that provides + functors must be instantiated by an implementation that provides a concrete IO monad. *) (** The [Net] module type defines how to connect to a remote node @@ -152,6 +152,7 @@ module type Server = sig val respond : ?headers:Cohttp.Header.t -> + ?flush:bool -> status:Cohttp.Code.status_code -> body:Cohttp_lwt_body.t -> unit -> (Response.t * Cohttp_lwt_body.t) Lwt.t diff --git a/lwt/cohttp_lwt_body.ml b/lwt/cohttp_lwt_body.ml index 24245fb36b..b90c36bb26 100644 --- a/lwt/cohttp_lwt_body.ml +++ b/lwt/cohttp_lwt_body.ml @@ -91,8 +91,8 @@ let get_length (body:t) : (int * t) Lwt.t = let len = String.length buf in return (len, (Some (`String buf))) -let write_body fn (body:t) = +let write_body ?(flush=(fun () -> return_unit)) fn (body:t) = match body with |None -> return () - |Some (`Stream st) -> Lwt_stream.iter_s fn st + |Some (`Stream st) -> Lwt_stream.iter_s (fun b -> fn b >>= flush) st |Some (`String s) -> fn s diff --git a/lwt/cohttp_lwt_body.mli b/lwt/cohttp_lwt_body.mli index d8857c2dc2..39a619338b 100644 --- a/lwt/cohttp_lwt_body.mli +++ b/lwt/cohttp_lwt_body.mli @@ -28,6 +28,6 @@ val body_of_stream : string Lwt_stream.t -> t val get_transfer_encoding : t -> Cohttp.Transfer.encoding val get_length : t -> (int * t) Lwt.t -val write_body : (string -> unit Lwt.t) -> t -> unit Lwt.t +val write_body : ?flush:(unit -> unit Lwt.t) -> (string -> unit Lwt.t) -> t -> unit Lwt.t val drain_body : t -> unit Lwt.t diff --git a/lwt/cohttp_lwt_unix_io.ml b/lwt/cohttp_lwt_unix_io.ml index 22975847ea..8b8ef7d23c 100644 --- a/lwt/cohttp_lwt_unix_io.ml +++ b/lwt/cohttp_lwt_unix_io.ml @@ -83,3 +83,6 @@ let write_line = check_debug (fun oc buf -> Lwt_io.write_line oc buf) (fun oc buf -> Printf.eprintf "\n%4d >>> %s\n%!" (Unix.getpid ()) buf; Lwt_io.write_line oc buf) + +let flush oc = + Lwt_io.flush oc diff --git a/lwt/cohttp_lwt_unix_net.ml b/lwt/cohttp_lwt_unix_net.ml index c3628a665e..11e2c12021 100644 --- a/lwt/cohttp_lwt_unix_net.ml +++ b/lwt/cohttp_lwt_unix_net.ml @@ -80,6 +80,7 @@ module Tcp_server = struct sock) () let process_accept ~sockaddr ~timeout callback (client,_) = + Lwt_unix.setsockopt client Lwt_unix.TCP_NODELAY true; let ic = Lwt_io.of_fd Lwt_io.input client in let oc = Lwt_io.of_fd Lwt_io.output client in diff --git a/mirage/cohttp_mirage.mli b/mirage/cohttp_mirage.mli index a9dcc05573..cf8a4d5f05 100644 --- a/mirage/cohttp_mirage.mli +++ b/mirage/cohttp_mirage.mli @@ -21,12 +21,12 @@ open Net (** The [Request] module holds the information about a HTTP request, - and also includes the {! Cohttp_lwt_mirage_io} functions to handle + and also includes the {! Cohttp_mirage_io} functions to handle large message bodies. *) module Request : Cohttp_lwt.Request with module IO = Cohttp_mirage_io (** The [Response] module holds the information about a HTTP response, - and also includes the {! Cohttp_lwt_mirage_io} functions to handle + and also includes the {! Cohttp_mirage_io} functions to handle large message bodies. *) module Response : Cohttp_lwt.Response with module IO = Cohttp_mirage_io diff --git a/mirage/cohttp_mirage_io.ml b/mirage/cohttp_mirage_io.ml index 6060a7f378..a1f2188c76 100644 --- a/mirage/cohttp_mirage_io.ml +++ b/mirage/cohttp_mirage_io.ml @@ -68,3 +68,7 @@ let write oc buf = let write_line oc buf = Channel.write_line oc buf; Channel.flush oc + +let flush oc = + (* NOOP since we flush in the normal writer functions above *) + return () diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 4f7dc58a18..eb3f5fb33b 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,39 +1,50 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: 6dba23f391c2bf4e8a13fae82774f5db) *) +(* DO NOT EDIT (digest: 13e3c9d1478882e81faae344a7b7cbb0) *) module OASISGettext = struct -(* # 21 "src/oasis/OASISGettext.ml" *) +(* # 22 "src/oasis/OASISGettext.ml" *) + let ns_ str = str + let s_ str = str - let f_ (str : ('a, 'b, 'c, 'd) format4) = + + let f_ (str: ('a, 'b, 'c, 'd) format4) = str + let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" + let init = [] + end module OASISExpr = struct -(* # 21 "src/oasis/OASISExpr.ml" *) +(* # 22 "src/oasis/OASISExpr.ml" *) + + open OASISGettext + type test = string + type flag = string + type t = | EBool of bool | ENot of t @@ -43,8 +54,10 @@ module OASISExpr = struct | ETest of test * string + type 'a choices = (t * 'a) list + let eval var_get t = let rec eval' = function @@ -75,6 +88,7 @@ module OASISExpr = struct in eval' t + let choose ?printer ?name var_get lst = let rec choose_aux = function @@ -111,22 +125,27 @@ module OASISExpr = struct in choose_aux (List.rev lst) + end -# 117 "myocamlbuild.ml" +# 132 "myocamlbuild.ml" module BaseEnvLight = struct -(* # 21 "src/base/BaseEnvLight.ml" *) +(* # 22 "src/base/BaseEnvLight.ml" *) + module MapString = Map.Make(String) + type t = string MapString.t + let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" + let load ?(allow_empty=false) ?(filename=default_filename) () = if Sys.file_exists filename then begin @@ -184,6 +203,7 @@ module BaseEnvLight = struct filename) end + let var_get name env = let rec var_expand str = let buff = @@ -205,6 +225,7 @@ module BaseEnvLight = struct in var_expand (MapString.find name env) + let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) @@ -212,87 +233,118 @@ module BaseEnvLight = struct end -# 215 "myocamlbuild.ml" +# 236 "myocamlbuild.ml" module MyOCamlbuildFindlib = struct -(* # 21 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) +(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) + - (** OCamlbuild extension, copied from + (** OCamlbuild extension, copied from * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild * by N. Pouillard and others * * Updated on 2009/02/28 * - * Modified by Sylvain Le Gall + * Modified by Sylvain Le Gall *) open Ocamlbuild_plugin + (* these functions are not really officially exported *) - let run_and_read = + let run_and_read = Ocamlbuild_pack.My_unix.run_and_read - let blank_sep_strings = + + let blank_sep_strings = Ocamlbuild_pack.Lexers.blank_sep_strings + let split s ch = - let x = - ref [] + let buf = Buffer.create 13 in + let x = ref [] in + let flush () = + x := (Buffer.contents buf) :: !x; + Buffer.clear buf in - let rec go s = - let pos = - String.index s ch - in - x := (String.before s pos)::!x; - go (String.after s (pos + 1)) - in - try - go s - with Not_found -> !x + String.iter + (fun c -> + if c = ch then + flush () + else + Buffer.add_char buf c) + s; + flush (); + List.rev !x + let split_nl s = split s '\n' + let before_space s = try String.before s (String.index s ' ') with Not_found -> s - (* this lists all supported packages *) + (* ocamlfind command *) + let ocamlfind x = + let ocamlfind_prog = + let env_filename = Pathname.basename BaseEnvLight.default_filename in + let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in + try + BaseEnvLight.var_get "ocamlfind" env + with Not_found -> + Printf.eprintf "W: Cannot get variable ocamlfind"; + "ocamlfind" + in + S[Sh ocamlfind_prog; x] + + (* This lists all supported packages. *) let find_packages () = List.map before_space (split_nl & run_and_read "ocamlfind list") - (* this is supposed to list available syntaxes, but I don't know how to do it. *) + + (* Mock to list available syntaxes. *) let find_syntaxes () = ["camlp4o"; "camlp4r"] - (* ocamlfind command *) - let ocamlfind x = S[A"ocamlfind"; x] let dispatch = function | Before_options -> - (* by using Before_options one let command line options have an higher priority *) - (* on the contrary using After_options will guarantee to have the higher priority *) - (* override default commands by ocamlfind ones *) + (* By using Before_options one let command line options have an higher + * priority on the contrary using After_options will guarantee to have + * the higher priority override default commands by ocamlfind ones *) Options.ocamlc := ocamlfind & A"ocamlc"; Options.ocamlopt := ocamlfind & A"ocamlopt"; Options.ocamldep := ocamlfind & A"ocamldep"; Options.ocamldoc := ocamlfind & A"ocamldoc"; - Options.ocamlmktop := ocamlfind & A"ocamlmktop" - + Options.ocamlmktop := ocamlfind & A"ocamlmktop"; + Options.ocamlmklib := ocamlfind & A"ocamlmklib" + | After_rules -> - - (* When one link an OCaml library/binary/package, one should use -linkpkg *) + + (* When one link an OCaml library/binary/package, one should use + * -linkpkg *) flag ["ocaml"; "link"; "program"] & A"-linkpkg"; - + (* For each ocamlfind package one inject the -package option when * compiling, computing dependencies, generating documentation and * linking. *) - List.iter + List.iter begin fun pkg -> - flag ["ocaml"; "compile"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "doc"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "link"; "pkg_"^pkg] & S[A"-package"; A pkg]; - flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S[A"-package"; A pkg]; - end + let base_args = [A"-package"; A pkg] in + let syn_args = [A"-syntax"; A "camlp4o"] in + let args = + (* Heuristic to identify syntax extensions: whether they end in + * ".syntax"; some might not *) + if Filename.check_suffix pkg "syntax" + then syn_args @ base_args + else base_args + in + flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; + flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; + flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; + flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; + flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; + end (find_packages ()); (* Like -package but for extensions syntax. Morover -syntax is useless @@ -301,14 +353,15 @@ module MyOCamlbuildFindlib = struct flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; - flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; + flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & + S[A"-syntax"; A syntax]; end (find_syntaxes ()); (* The default "thread" tag is not compatible with ocamlfind. * Indeed, the default rules add the "threads.cma" or "threads.cmxa" * options when using this tag. When using the "-linkpkg" option with * ocamlfind, this module will then be added twice on the command line. - * + * * To solve this, one approach is to add the "-thread" option when using * the "threads" package using the previous plugin. *) @@ -317,13 +370,13 @@ module MyOCamlbuildFindlib = struct flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]) - | _ -> + | _ -> () - end module MyOCamlbuildBase = struct -(* # 21 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) +(* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) + (** Base functions for writing myocamlbuild.ml @author Sylvain Le Gall @@ -331,51 +384,61 @@ module MyOCamlbuildBase = struct + + open Ocamlbuild_plugin module OC = Ocamlbuild_pack.Ocaml_compiler + type dir = string type file = string type name = string type tag = string -(* # 56 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) + +(* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) + type t = { - lib_ocaml: (name * dir list) list; - lib_c: (name * dir * file list) list; + lib_ocaml: (name * dir list * string list) list; + lib_c: (name * dir * file list) list; flags: (tag list * (spec OASISExpr.choices)) list; (* Replace the 'dir: include' from _tags by a precise interdepends in * directory. *) - includes: (dir * dir list) list; + includes: (dir * dir list) list; } + let env_filename = - Pathname.basename + Pathname.basename BaseEnvLight.default_filename + let dispatch_combine lst = fun e -> - List.iter + List.iter (fun dispatch -> dispatch e) - lst + lst + let tag_libstubs nm = "use_lib"^nm^"_stubs" + let nm_libstubs nm = nm^"_stubs" - let dispatch t e = - let env = - BaseEnvLight.load - ~filename:env_filename + + let dispatch t e = + let env = + BaseEnvLight.load + ~filename:env_filename ~allow_empty:true () in - match e with + match e with | Before_options -> let no_trailing_dot s = if String.length s >= 1 && s.[0] = '.' then @@ -385,7 +448,7 @@ module MyOCamlbuildBase = struct in List.iter (fun (opt, var) -> - try + try opt := no_trailing_dot (BaseEnvLight.var_get var env) with Not_found -> Printf.eprintf "W: Cannot get variable %s" var) @@ -395,25 +458,34 @@ module MyOCamlbuildBase = struct Options.ext_dll, "ext_dll"; ] - | After_rules -> + | After_rules -> (* Declare OCaml libraries *) - List.iter + List.iter (function - | nm, [] -> - ocaml_lib nm - | nm, dir :: tl -> + | nm, [], intf_modules -> + ocaml_lib nm; + let cmis = + List.map (fun m -> (String.uncapitalize m) ^ ".cmi") + intf_modules in + dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis + | nm, dir :: tl, intf_modules -> ocaml_lib ~dir:dir (dir^"/"^nm); - List.iter - (fun dir -> + List.iter + (fun dir -> List.iter (fun str -> flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) ["compile"; "infer_interface"; "doc"]) - tl) + tl; + let cmis = + List.map (fun m -> dir^"/"^(String.uncapitalize m)^".cmi") + intf_modules in + dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] + cmis) t.lib_ocaml; (* Declare directories dependencies, replace "include" in _tags. *) - List.iter + List.iter (fun (dir, include_dirs) -> Pathname.define_context dir include_dirs) t.includes; @@ -428,7 +500,7 @@ module MyOCamlbuildBase = struct flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); - + flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); @@ -443,11 +515,11 @@ module MyOCamlbuildBase = struct (* TODO: be more specific about what depends on headers *) (* Depends on .h files *) - dep ["compile"; "c"] + dep ["compile"; "c"] headers; (* Setup search path for lib *) - flag ["link"; "ocaml"; "use_"^lib] + flag ["link"; "ocaml"; "use_"^lib] (S[A"-I"; P(dir)]); ) t.lib_c; @@ -455,36 +527,38 @@ module MyOCamlbuildBase = struct (* Add flags *) List.iter (fun (tags, cond_specs) -> - let spec = + let spec = BaseEnvLight.var_choose cond_specs env in flag tags & spec) t.flags - | _ -> + | _ -> () + let dispatch_default t = - dispatch_combine + dispatch_combine [ dispatch t; MyOCamlbuildFindlib.dispatch; ] + end -# 476 "myocamlbuild.ml" +# 550 "myocamlbuild.ml" open Ocamlbuild_plugin;; let package_default = { MyOCamlbuildBase.lib_ocaml = [ - ("cohttp", ["cohttp"]); - ("cohttp_lwt", ["lwt"]); - ("cohttp_lwt_unix", ["lwt"]); - ("cohttp_mirage_unix", ["mirage"]); - ("cohttp_mirage_xen", ["mirage"]); - ("cohttp_async", ["async"]) + ("cohttp", ["cohttp"], []); + ("cohttp_lwt", ["lwt"], []); + ("cohttp_lwt_unix", ["lwt"], []); + ("cohttp_mirage_unix", ["mirage"], []); + ("cohttp_mirage_xen", ["mirage"], []); + ("cohttp_async", ["async"], []) ]; lib_c = []; flags = []; @@ -493,14 +567,15 @@ let package_default = ("mirage", ["lwt"]); ("lwt", ["cohttp"]); ("lib_test", ["async"; "cohttp"; "lwt"]); + ("bin", ["async"; "cohttp"]); ("async", ["cohttp"]) - ]; - } + ] + } ;; let dispatch_default = MyOCamlbuildBase.dispatch_default package_default;; -# 504 "myocamlbuild.ml" +# 579 "myocamlbuild.ml" (* OASIS_STOP *) open Ocamlbuild_plugin diff --git a/scripts/codes/1.json b/scripts/codes/1.json new file mode 100644 index 0000000000..1cad150a00 --- /dev/null +++ b/scripts/codes/1.json @@ -0,0 +1,89 @@ +{ + "class":{ + "title":"Informational", + "class":"1" + }, + "codes":{ + "100":{ + "code":"100", + "title":"Continue", + "summary":"Client should continue with request", + "descriptions":{ + "wikipedia":{ + "body":"This means that the server has received the request headers, and that the client should proceed to send the request body (in the case of a request for which a body needs to be sent; for example, a POST request). If the request body is large, sending it to a server when a request has already been rejected based upon inappropriate headers is inefficient. To have a server check if the request could be accepted based on the request's headers alone, a client must send Expect: 100-continue as a header in its initial request and check if a 100 Continue status code is received in response before continuing (or receive 417 Expectation Failed and not continue).", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#100" + }, + "ietf":{ + "body":"The client SHOULD continue with its request. This interim response is used to inform the client that the initial part of the request has been received and has not yet been rejected by the server. The client SHOULD continue by sending the remainder of the request or, if the request has already been completed, ignore this response. The server MUST send a final response after the request has been completed.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":continue" + } + } + }, + "101":{ + "code":"101", + "title":"Switching Protocols", + "summary":"Server is switching protocols", + "descriptions":{ + "wikipedia":{ + "body":"This means the requester has asked the server to switch protocols and the server is acknowledging that it will do so.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#101" + }, + "ietf":{ + "body":"The server understands and is willing to comply with the client's request, via the Upgrade message header field, for a change in the application protocol being used on this connection. The server will switch protocols to those defined by the response's Upgrade header field immediately after the empty line which terminates the 101 response. \r\nThe protocol SHOULD be switched only when it is advantageous to do so. For example, switching to a newer version of HTTP is advantageous over older versions, and switching to a real-time, synchronous protocol might be advantageous when delivering resources that use such features.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":switching_protocols" + } + } + }, + "102":{ + "code":"102", + "title":"Processing (WebDAV) (RFC 2518)", + "summary":"Server has received and is processing the request", + "descriptions":{ + "wikipedia":{ + "body":"As a WebDAV request may contain many sub-requests involving file operations, it may take a long time to complete the request. This code indicates that the server has received and is processing the request, but no response is available yet. This prevents the client from timing out and assuming the request was lost.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#102" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":processing" + } + } + }, + "103":{ + "code":"103", + "title":"Checkpoint", + "summary":"resume aborted PUT or POST requests", + "descriptions":{ + "wikipedia":{ + "body":"This code is used in the Resumable HTTP Requests Proposal to resume aborted PUT or POST requests.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#103" + } + } + }, + "122":{ + "code":"122", + "title":"Request-URI too long", + "summary":"URI is longer than a maximum of 2083 characters", + "descriptions":{ + "wikipedia":{ + "body":"This is a non-standard IE7-only code which means the URI is longer than a maximum of 2083 characters.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#122" + } + } + } + } +} \ No newline at end of file diff --git a/scripts/codes/2.json b/scripts/codes/2.json new file mode 100644 index 0000000000..59ba4a1e0d --- /dev/null +++ b/scripts/codes/2.json @@ -0,0 +1,200 @@ +{ + "class":{ + "title":"Success", + "class":"2" + }, + "codes":{ + "200":{ + "code":"200", + "title":"OK", + "summary":"standard response for successful HTTP requests", + "descriptions":{ + "wikipedia":{ + "body":"Standard response for successful HTTP requests. The actual response will depend on the request method used. In a GET request, the response will contain an entity corresponding to the requested resource. In a POST request the response will contain an entity describing or containing the result of the action.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#200" + }, + "ietf":{ + "body":"The request has succeeded. The information returned with the response is dependent on the method used in the request, for example: GET an entity corresponding to the requested resource is sent in the response; HEAD the entity-header fields corresponding to the requested resource are sent in the response without any message-body; POST an entity describing or containing the result of the action;", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":ok" + } + } + }, + "201":{ + "code":"201", + "title":"Created", + "summary":"request has been fulfilled; new resource created", + "descriptions":{ + "wikipedia":{ + "body":"The request has been fulfilled and resulted in a new resource being created.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#201" + }, + "ietf":{ + "body":"The request has been fulfilled and resulted in a new resource being created. The newly created resource can be referenced by the URI(s) returned in the entity of the response, with the most specific URI for the resource given by a Location header field. The response SHOULD include an entity containing a list of resource characteristics and location(s) from which the user or user agent can choose the one most appropriate. The entity format is specified by the media type given in the Content-Type header field. The origin server MUST create the resource before returning the 201 status code. If the action cannot be carried out immediately, the server SHOULD respond with 202 (Accepted) response instead.\r\n A 201 response MAY contain an ETag response header field indicating the current value of the entity tag for the requested variant just created.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":created" + } + } + }, + "202":{ + "code":"202", + "title":"Accepted", + "summary":"request accepted, processing pending", + "descriptions":{ + "wikipedia":{ + "body":"The request has been accepted for processing, but the processing has not been completed. The request might or might not eventually be acted upon, as it might be disallowed when processing actually takes place.[2]", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#202" + }, + "ietf":{ + "body":"The request has been accepted for processing, but the processing has not been completed. The request might or might not eventually be acted upon, as it might be disallowed when processing actually takes place. There is no facility for re-sending a status code from an asynchronous operation such as this. \r\nThe 202 response is intentionally non-committal. Its purpose is to allow a server to accept a request for some other process (perhaps a batch-oriented process that is only run once per day) without requiring that the user agent's connection to the server persist until the process is completed. The entity returned with this response SHOULD include an indication of the request's current status and either a pointer to a status monitor or some estimate of when the user can expect the request to be fulfilled.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":accepted" + } + } + }, + "203":{ + "code":"203", + "title":"Non-Authoritative Information (since HTTP\/1.1)", + "summary":"request processed, information may be from another source", + "descriptions":{ + "wikipedia":{ + "body":"The server successfully processed the request, but is returning information that may be from another source.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#203" + }, + "ietf":{ + "body":"The returned metainformation in the entity-header is not the definitive set as available from the origin server, but is gathered from a local or a third-party copy. The set presented MAY be a subset or superset of the original version. For example, including local annotation information about the resource might result in a superset of the metainformation known by the origin server. Use of this response code is not required and is only appropriate when the response would otherwise be 200 (OK).", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":non_authoritative_information" + } + } + }, + "204":{ + "code":"204", + "title":"No Content", + "summary":"request processed, no content returned", + "descriptions":{ + "wikipedia":{ + "body":"The server successfully processed the request, but is not returning any content.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#204" + }, + "ietf":{ + "body":"The server has fulfilled the request but does not need to return an entity-body, and might want to return updated metainformation. The response MAY include new or updated metainformation in the form of entity-headers, which if present SHOULD be associated with the requested variant.\r\nIf the client is a user agent, it SHOULD NOT change its document view from that which caused the request to be sent. This response is primarily intended to allow input for actions to take place without causing a change to the user agent's active document view, although any new or updated metainformation SHOULD be applied to the document currently in the user agent's active view.\r\nThe 204 response MUST NOT include a message-body, and thus is always terminated by the first empty line after the header fields.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":no_content" + } + } + }, + "205":{ + "code":"205", + "title":"Reset Content", + "summary":"request processed, no content returned, reset document view", + "descriptions":{ + "wikipedia":{ + "body":"The server successfully processed the request, but is not returning any content. Unlike a 204 response, this response requires that the requester reset the document view.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#205" + }, + "ietf":{ + "body":"The server has fulfilled the request and the user agent SHOULD reset the document view which caused the request to be sent. This response is primarily intended to allow input for actions to take place via user input, followed by a clearing of the form in which the input is given so that the user can easily initiate another input action. The response MUST NOT include an entity.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":reset_content" + } + } + }, + "206":{ + "code":"206", + "title":"Partial Content", + "summary":"partial resource return due to request header", + "descriptions":{ + "wikipedia":{ + "body":"The server is delivering only part of the resource due to a range header sent by the client. The range header is used by tools like wget to enable resuming of interrupted downloads, or split a download into multiple simultaneous streams.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#206" + }, + "ietf":{ + "body":"The server has fulfilled the partial GET request for the resource. The request MUST have included a Range header field indicating the desired range, and MAY have included an If-Range header field to make the request conditional.\r\nThe response MUST include the following header fields:\r\nEither a Content-Range header field (section 14.16) indicating the range included with this response, or a multipart\/byteranges Content-Type including Content-Range fields for each part. If a Content-Length header field is present in the response, its value MUST match the actual number of OCTETs transmitted in the message-body.\r\nDate\r\nETag and\/or Content-Location, if the header would have been sent in a 200 response to the same request\r\nExpires, Cache-Control, and\/or Vary, if the field-value might differ from that sent in any previous response for the same variant\r\nIf the 206 response is the result of an If-Range request that used a strong cache validator, the response SHOULD NOT include other entity-headers. If the response is the result of an If-Range request that used a weak validator, the response MUST NOT include other entity-headers; this prevents inconsistencies between cached entity-bodies and updated headers. Otherwise, the response MUST include all of the entity-headers that would have been returned with a 200 (OK) response to the same request.\r\nA cache MUST NOT combine a 206 response with other previously cached content if the ETag or Last-Modified headers do not match exactly.\r\nA cache that does not support the Range and Content-Range headers MUST NOT cache 206 (Partial) responses.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":partial_content" + } + } + }, + "207":{ + "code":"207", + "title":"Multi-Status (WebDAV) (RFC 4918)", + "summary":"XML, can contain multiple separate responses", + "descriptions":{ + "wikipedia":{ + "body":"The message body that follows is an XML message and can contain a number of separate response codes, depending on how many sub-requests were made.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#207" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":multi_status" + } + } + }, + "208":{ + "code":"208", + "title":"Already Reported (WebDAV) (RFC 5842)", + "summary":"results previously returned ", + "descriptions":{ + "wikipedia":{ + "body":"The members of a DAV binding have already been enumerated in a previous reply to this request, and are not being included again.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#208" + } + } + }, + "226":{ + "code":"226", + "title":"IM Used (RFC 3229)", + "summary":"request fulfilled, reponse is instance-manipulations", + "descriptions":{ + "wikipedia":{ + "body":"The server has fulfilled a GET request for the resource, and the response is a representation of the result of one or more instance-manipulations applied to the current instance.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#226" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":im_used" + } + } + } + } +} diff --git a/scripts/codes/3.json b/scripts/codes/3.json new file mode 100644 index 0000000000..f725ca6ab4 --- /dev/null +++ b/scripts/codes/3.json @@ -0,0 +1,187 @@ +{ + "class":{ + "title":"Redirection", + "class":"3" + }, + "codes":{ + "300":{ + "code":"300", + "title":"Multiple Choices", + "summary":"multiple options for the resource delivered", + "descriptions":{ + "wikipedia":{ + "body":"Indicates multiple options for the resource that the client may follow. It, for instance, could be used to present different format options for video, list files with different extensions, or word sense disambiguation.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#300" + }, + "ietf":{ + "body":"The requested resource corresponds to any one of a set of representations, each with its own specific location, and agent- driven negotiation information is being provided so that the user (or user agent) can select a preferred representation and redirect its request to that location.\r\nUnless it was a HEAD request, the response SHOULD include an entity containing a list of resource characteristics and location(s) from which the user or user agent can choose the one most appropriate. The entity format is specified by the media type given in the Content- Type header field. Depending upon the format and the capabilities of the user agent, selection of the most appropriate choice MAY be performed automatically. However, this specification does not define any standard for such automatic selection.\r\nIf the server has a preferred choice of representation, it SHOULD include the specific URI for that representation in the Location field; user agents MAY use the Location field value for automatic redirection. This response is cacheable unless indicated otherwise.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":multiple_choices" + } + } + }, + "301":{ + "code":"301", + "title":"Moved Permanently", + "summary":"this and all future requests directed to the given URI", + "descriptions":{ + "wikipedia":{ + "body":"This and all future requests should be directed to the given URI.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#301" + }, + "ietf":{ + "body":"The requested resource has been assigned a new permanent URI and any future references to this resource SHOULD use one of the returned URIs. Clients with link editing capabilities ought to automatically re-link references to the Request-URI to one or more of the new references returned by the server, where possible. This response is cacheable unless indicated otherwise.\r\nThe new permanent URI SHOULD be given by the Location field in the response. Unless the request method was HEAD, the entity of the response SHOULD contain a short hypertext note with a hyperlink to the new URI(s).\r\nIf the 301 status code is received in response to a request other than GET or HEAD, the user agent MUST NOT automatically redirect the request unless it can be confirmed by the user, since this might change the conditions under which the request was issued.\r\nNote: When automatically redirecting a POST request after receiving a 301 status code, some existing HTTP\/1.0 user agents will erroneously change it into a GET request.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":moved_permanently" + } + } + }, + "302":{ + "code":"302", + "title":"Found", + "summary":"temporary response to request found via alternative URI", + "descriptions":{ + "wikipedia":{ + "body":"This is an example of industrial practice contradicting the standard. HTTP\/1.0 specification (RFC 1945) required the client to perform a temporary redirect (the original describing phrase was \"Moved Temporarily\"), but popular browsers implemented 302 with the functionality of a 303 See Other. Therefore, HTTP\/1.1 added status codes 303 and 307 to distinguish between the two behaviours. However, some Web applications and frameworks use the 302 status code as if it were the 303.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#302" + }, + "ietf":{ + "body":"The requested resource resides temporarily under a different URI. Since the redirection might be altered on occasion, the client SHOULD continue to use the Request-URI for future requests. This response is only cacheable if indicated by a Cache-Control or Expires header field.\r\nThe temporary URI SHOULD be given by the Location field in the response. Unless the request method was HEAD, the entity of the response SHOULD contain a short hypertext note with a hyperlink to the new URI(s).\r\nIf the 302 status code is received in response to a request other than GET or HEAD, the user agent MUST NOT automatically redirect the request unless it can be confirmed by the user, since this might change the conditions under which the request was issued.\r\nNote: RFC 1945 and RFC 2068 specify that the client is not allowed to change the method on the redirected request. However, most existing user agent implementations treat 302 as if it were a 303 response, performing a GET on the Location field-value regardless of the original request method. The status codes 303 and 307 have been added for servers that wish to make unambiguously clear which kind of reaction is expected of the client.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":found" + } + } + }, + "303":{ + "code":"303", + "title":"See Other", + "summary":"permanent response to request found via alternative URI", + "descriptions":{ + "wikipedia":{ + "body":"The response to the request can be found under another URI using a GET method. When received in response to a POST (or PUT\/DELETE), it should be assumed that the server has received the data and the redirect should be issued with a separate GET message.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#303" + }, + "ietf":{ + "body":"The response to the request can be found under a different URI and SHOULD be retrieved using a GET method on that resource. This method exists primarily to allow the output of a POST-activated script to redirect the user agent to a selected resource. The new URI is not a substitute reference for the originally requested resource. The 303 response MUST NOT be cached, but the response to the second (redirected) request might be cacheable.\r\nThe different URI SHOULD be given by the Location field in the response. Unless the request method was HEAD, the entity of the response SHOULD contain a short hypertext note with a hyperlink to the new URI(s).\r\nNote: Many pre-HTTP\/1.1 user agents do not understand the 303 status. When interoperability with such clients is a concern, the 302 status code may be used instead, since most user agents react to a 302 response as described here for 303.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":see_other" + } + } + }, + "304":{ + "code":"304", + "title":"Not Modified", + "summary":"resource has not been modified since last requested", + "descriptions":{ + "wikipedia":{ + "body":"Indicates the resource has not been modified since last requested. Typically, the HTTP client provides a header like the If-Modified-Since header to provide a time against which to compare. Using this saves bandwidth and reprocessing on both the server and client, as only the header data must be sent and received in comparison to the entirety of the page being re-processed by the server, then sent again using more bandwidth of the server and client.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#304" + }, + "ietf":{ + "body":"If the client has performed a conditional GET request and access is allowed, but the document has not been modified, the server SHOULD respond with this status code. The 304 response MUST NOT contain a message-body, and thus is always terminated by the first empty line after the header fields.\r\nThe response MUST include the following header fields:\r\nDate, unless its omission is required\r\nIf a clockless origin server obeys these rules, and proxies and clients add their own Date to any response received without one (as already specified by RFC 2068), caches will operate correctly.\r\nETag and\/or Content-Location, if the header would have been sent in a 200 response to the same request\r\nExpires, Cache-Control, and\/or Vary, if the field-value might differ from that sent in any previous response for the same variant\r\nIf the conditional GET used a strong cache validator, the response SHOULD NOT include other entity-headers. Otherwise (i.e., the conditional GET used a weak validator), the response MUST NOT include other entity-headers; this prevents inconsistencies between cached entity-bodies and updated headers.\r\nIf a 304 response indicates an entity not currently cached, then the cache MUST disregard the response and repeat the request without the conditional.\r\nIf a cache uses a received 304 response to update a cache entry, the cache MUST update the entry to reflect any new field values given in the response.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":not_modified" + } + } + }, + "305":{ + "code":"305", + "title":"Use Proxy (since HTTP\/1.1)", + "summary":"content located elsewhere, retrieve from there", + "descriptions":{ + "wikipedia":{ + "body":"Many HTTP clients (such as Mozilla and Internet Explorer) do not correctly handle responses with this status code, primarily for security reasons.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#305" + }, + "ietf":{ + "body":"The requested resource MUST be accessed through the proxy given by the Location field. The Location field gives the URI of the proxy. The recipient is expected to repeat this single request via the proxy. 305 responses MUST only be generated by origin servers.\r\nNote: RFC 2068 was not clear that 305 was intended to redirect a single request, and to be generated by origin servers only. Not observing these limitations has significant security consequences.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":use_proxy" + } + } + }, + "306":{ + "code":"306", + "title":"Switch Proxy", + "summary":"subsequent requests should use the specified proxy", + "descriptions":{ + "wikipedia":{ + "body":"No longer used. Originally meant \"Subsequent requests should use the specified proxy.\"", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#306" + }, + "ietf":{ + "body":"The 306 status code was used in a previous version of the specification, is no longer used, and the code is reserved.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + } + }, + "307":{ + "code":"307", + "title":"Temporary Redirect (since HTTP\/1.1)", + "summary":"connect again to different URI as provided", + "descriptions":{ + "wikipedia":{ + "body":"In this occasion, the request should be repeated with another URI, but future requests can still use the original URI. In contrast to 303, the request method should not be changed when reissuing the original request. For instance, a POST request must be repeated using another POST request.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#307" + }, + "ietf":{ + "body":"The requested resource resides temporarily under a different URI. Since the redirection MAY be altered on occasion, the client SHOULD continue to use the Request-URI for future requests. This response is only cacheable if indicated by a Cache-Control or Expires header field.\r\nThe temporary URI SHOULD be given by the Location field in the response. Unless the request method was HEAD, the entity of the response SHOULD contain a short hypertext note with a hyperlink to the new URI(s) , since many pre-HTTP\/1.1 user agents do not understand the 307 status. Therefore, the note SHOULD contain the information necessary for a user to repeat the original request on the new URI.\r\nIf the 307 status code is received in response to a request other than GET or HEAD, the user agent MUST NOT automatically redirect the request unless it can be confirmed by the user, since this might change the conditions under which the request was issued.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":temporary_redirect" + } + } + }, + "308":{ + "code":"308", + "title":"Resume Incomplete", + "summary":"resumable HTTP requests", + "descriptions":{ + "wikipedia":{ + "body":"This code is used in the Resumable HTTP Requests Proposal to resume aborted PUT or POST requests.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#308" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":no_content" + } + } + } + } +} diff --git a/scripts/codes/4.json b/scripts/codes/4.json new file mode 100644 index 0000000000..a0c89ab0d6 --- /dev/null +++ b/scripts/codes/4.json @@ -0,0 +1,570 @@ +{ + "class":{ + "title":"Client Error", + "class":"4" + }, + "codes":{ + "400":{ + "code":"400", + "title":"Bad Request", + "summary":"request cannot be fulfilled due to bad syntax", + "descriptions":{ + "wikipedia":{ + "body":"The request cannot be fulfilled due to bad syntax.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#400" + }, + "ietf":{ + "body":"The request could not be understood by the server due to malformed syntax. The client SHOULD NOT repeat the request without modifications.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":bad_request" + } + } + }, + "401":{ + "code":"401", + "title":"Unauthorized", + "summary":"authentication is possible but has failed ", + "descriptions":{ + "wikipedia":{ + "body":"Similar to 403 Forbidden, but specifically for use when authentication is possible but has failed or not yet been provided. The response must include a WWW-Authenticate header field containing a challenge applicable to the requested resource. See Basic access authentication and Digest access authentication.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#401" + }, + "ietf":{ + "body":"The request requires user authentication. The response MUST include a WWW-Authenticate header field containing a challenge applicable to the requested resource. The client MAY repeat the request with a suitable Authorization header field. If the request already included Authorization credentials, then the 401 response indicates that authorization has been refused for those credentials. If the 401 response contains the same challenge as the prior response, and the user agent has already attempted authentication at least once, then the user SHOULD be presented the entity that was given in the response, since that entity might include relevant diagnostic information. HTTP access authentication is explained in \"HTTP Authentication: Basic and Digest Access Authentication\".", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":unauthorized" + } + } + }, + "402":{ + "code":"402", + "title":"Payment Required", + "summary":"payment required, reserved for future use", + "descriptions":{ + "wikipedia":{ + "body":"Reserved for future use. The original intention was that this code might be used as part of some form of digital cash or micropayment scheme, but that has not happened, and this code is not usually used. As an example of its use, however, Apple's MobileMe service generates a 402 error (\"httpStatusCode:402\" in the Mac OS X Console log) if the MobileMe account is delinquent.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#402" + }, + "ietf":{ + "body":"This code is reserved for future use.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":payment_required" + } + } + }, + "403":{ + "code":"403", + "title":"Forbidden", + "summary":"server refuses to respond to request", + "descriptions":{ + "wikipedia":{ + "body":"The request was a legal request, but the server is refusing to respond to it. Unlike a 401 Unauthorized response, authenticating will make no difference.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#403" + }, + "ietf":{ + "body":"The server understood the request, but is refusing to fulfill it. Authorization will not help and the request SHOULD NOT be repeated. If the request method was not HEAD and the server wishes to make public why the request has not been fulfilled, it SHOULD describe the reason for the refusal in the entity. If the server does not wish to make this information available to the client, the status code 404 (Not Found) can be used instead.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":forbidden" + } + } + }, + "404":{ + "code":"404", + "title":"Not Found", + "summary":"requested resource could not be found", + "descriptions":{ + "wikipedia":{ + "body":"The requested resource could not be found but may be available again in the future. Subsequent requests by the client are permissible.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#404" + }, + "ietf":{ + "body":"The server has not found anything matching the Request-URI. No indication is given of whether the condition is temporary or permanent. The 410 (Gone) status code SHOULD be used if the server knows, through some internally configurable mechanism, that an old resource is permanently unavailable and has no forwarding address. This status code is commonly used when the server does not wish to reveal exactly why the request has been refused, or when no other response is applicable.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":not_found" + } + } + }, + "405":{ + "code":"405", + "title":"Method Not Allowed", + "summary":"request method not supported by that resource", + "descriptions":{ + "wikipedia":{ + "body":"A request was made of a resource using a request method not supported by that resource; for example, using GET on a form which requires data to be presented via POST, or using PUT on a read-only resource.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#405" + }, + "ietf":{ + "body":"The method specified in the Request-Line is not allowed for the resource identified by the Request-URI. The response MUST include an Allow header containing a list of valid methods for the requested resource.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":method_not_allowed" + } + } + }, + "406":{ + "code":"406", + "title":"Not Acceptable", + "summary":"content not acceptable according to the Accept headers", + "descriptions":{ + "wikipedia":{ + "body":"The requested resource is only capable of generating content not acceptable according to the Accept headers sent in the request.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#406" + }, + "ietf":{ + "body":"The resource identified by the request is only capable of generating response entities which have content characteristics not acceptable according to the accept headers sent in the request.\r\nUnless it was a HEAD request, the response SHOULD include an entity containing a list of available entity characteristics and location(s) from which the user or user agent can choose the one most appropriate. The entity format is specified by the media type given in the Content-Type header field. Depending upon the format and the capabilities of the user agent, selection of the most appropriate choice MAY be performed automatically. However, this specification does not define any standard for such automatic selection.\r\nNote: HTTP\/1.1 servers are allowed to return responses which are not acceptable according to the accept headers sent in the request. In some cases, this may even be preferable to sending a 406 response. User agents are encouraged to inspect the headers of an incoming response to determine if it is acceptable.\r\nIf the response could be unacceptable, a user agent SHOULD temporarily stop receipt of more data and query the user for a decision on further actions.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":not_acceptable" + } + } + }, + "407":{ + "code":"407", + "title":"Proxy Authentication Required", + "summary":"client must first authenticate itself with the proxy", + "descriptions":{ + "wikipedia":{ + "body":"The client must first authenticate itself with the proxy.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#407" + }, + "ietf":{ + "body":"This code is similar to 401 (Unauthorized), but indicates that the client must first authenticate itself with the proxy. The proxy MUST return a Proxy-Authenticate header field containing a challenge applicable to the proxy for the requested resource. The client MAY repeat the request with a suitable Proxy-Authorization header field. HTTP access authentication is explained in \"HTTP Authentication: Basic and Digest Access Authentication\".", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":proxy_authentication_required" + } + } + }, + "408":{ + "code":"408", + "title":"Request Timeout", + "summary":"server timed out waiting for the request", + "descriptions":{ + "wikipedia":{ + "body":"The server timed out waiting for the request. According to W3 HTTP specifications: \"The client did not produce a request within the time that the server was prepared to wait. The client MAY repeat the request without modifications at any later time.\"", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#408" + }, + "ietf":{ + "body":"The client did not produce a request within the time that the server was prepared to wait. The client MAY repeat the request without modifications at any later time.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":request_timeout" + } + } + }, + "409":{ + "code":"409", + "title":"Conflict", + "summary":"request could not be processed because of conflict", + "descriptions":{ + "wikipedia":{ + "body":"Indicates that the request could not be processed because of conflict in the request, such as an edit conflict.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#409" + }, + "ietf":{ + "body":"The request could not be completed due to a conflict with the current state of the resource. This code is only allowed in situations where it is expected that the user might be able to resolve the conflict and resubmit the request. The response body SHOULD include enough information for the user to recognize the source of the conflict. Ideally, the response entity would include enough information for the user or user agent to fix the problem; however, that might not be possible and is not required.\r\nConflicts are most likely to occur in response to a PUT request. For example, if versioning were being used and the entity being PUT included changes to a resource which conflict with those made by an earlier (third-party) request, the server might use the 409 response to indicate that it can't complete the request. In this case, the response entity would likely contain a list of the differences between the two versions in a format defined by the response Content-Type.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":conflict" + } + } + }, + "410":{ + "code":"410", + "title":"Gone", + "summary":"resource is no longer available and will not be available again", + "descriptions":{ + "wikipedia":{ + "body":"Indicates that the resource requested is no longer available and will not be available again. This should be used when a resource has been intentionally removed and the resource should be purged. Upon receiving a 410 status code, the client should not request the resource again in the future. Clients such as search engines should remove the resource from their indices. Most use cases do not require clients and search engines to purge the resource, and a \"404 Not Found\" may be used instead.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#410" + }, + "ietf":{ + "body":"The requested resource is no longer available at the server and no forwarding address is known. This condition is expected to be considered permanent. Clients with link editing capabilities SHOULD delete references to the Request-URI after user approval. If the server does not know, or has no facility to determine, whether or not the condition is permanent, the status code 404 (Not Found) SHOULD be used instead. This response is cacheable unless indicated otherwise.\r\nThe 410 response is primarily intended to assist the task of web maintenance by notifying the recipient that the resource is intentionally unavailable and that the server owners desire that remote links to that resource be removed. Such an event is common for limited-time, promotional services and for resources belonging to individuals no longer working at the server's site. It is not necessary to mark all permanently unavailable resources as \"gone\" or to keep the mark for any length of time -- that is left to the discretion of the server owner.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":gone" + } + } + }, + "411":{ + "code":"411", + "title":"Length Required", + "summary":"request did not specify the length of its content", + "descriptions":{ + "wikipedia":{ + "body":"The request did not specify the length of its content, which is required by the requested resource.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#411" + }, + "ietf":{ + "body":"The server refuses to accept the request without a defined Content- Length. The client MAY repeat the request if it adds a valid Content-Length header field containing the length of the message-body in the request message.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":length_required" + } + } + }, + "412":{ + "code":"412", + "title":"Precondition Failed", + "summary":"server does not meet request preconditions", + "descriptions":{ + "wikipedia":{ + "body":"The server does not meet one of the preconditions that the requester put on the request.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#412" + }, + "ietf":{ + "body":"The precondition given in one or more of the request-header fields evaluated to false when it was tested on the server. This response code allows the client to place preconditions on the current resource metainformation (header field data) and thus prevent the requested method from being applied to a resource other than the one intended.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":precondition_failed" + } + } + }, + "413":{ + "code":"413", + "title":"Request Entity Too Large", + "summary":"request is larger than the server is willing or able to process", + "descriptions":{ + "wikipedia":{ + "body":"The request is larger than the server is willing or able to process.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#413" + }, + "ietf":{ + "body":"The server is refusing to process a request because the request entity is larger than the server is willing or able to process. The server MAY close the connection to prevent the client from continuing the request.\r\nIf the condition is temporary, the server SHOULD include a Retry- After header field to indicate that it is temporary and after what time the client MAY try again.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":request_entity_too_large" + } + } + }, + "414":{ + "code":"414", + "title":"Request-URI Too Long", + "summary":"URI provided was too long for the server to process", + "descriptions":{ + "wikipedia":{ + "body":"The URI provided was too long for the server to process.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#414" + }, + "ietf":{ + "body":"The server is refusing to service the request because the Request-URI is longer than the server is willing to interpret. This rare condition is only likely to occur when a client has improperly converted a POST request to a GET request with long query information, when the client has descended into a URI \"black hole\" of redirection (e.g., a redirected URI prefix that points to a suffix of itself), or when the server is under attack by a client attempting to exploit security holes present in some servers using fixed-length buffers for reading or manipulating the Request-URI.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":request_uri_too_long" + } + } + }, + "415":{ + "code":"415", + "title":"Unsupported Media Type", + "summary":"server does not support media type", + "descriptions":{ + "wikipedia":{ + "body":"The request entity has a media type which the server or resource does not support. For example, the client uploads an image as image\/svg+xml, but the server requires that images use a different format.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#415" + }, + "ietf":{ + "body":"The server is refusing to service the request because the entity of the request is in a format not supported by the requested resource for the requested method.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":unsupported_media_type" + } + } + }, + "416":{ + "code":"416", + "title":"Requested Range Not Satisfiable", + "summary":"client has asked for unprovidable portion of the file", + "descriptions":{ + "wikipedia":{ + "body":"The client has asked for a portion of the file, but the server cannot supply that portion. For example, if the client asked for a part of the file that lies beyond the end of the file.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#416" + }, + "ietf":{ + "body":"A server SHOULD return a response with this status code if a request included a Range request-header field, and none of the range-specifier values in this field overlap the current extent of the selected resource, and the request did not include an If-Range request-header field. (For byte-ranges, this means that the first- byte-pos of all of the byte-range-spec values were greater than the current length of the selected resource.)\r\nWhen this status code is returned for a byte-range request, the response SHOULD include a Content-Range entity-header field specifying the current length of the selected resource. This response MUST NOT use the multipart\/byteranges content- type.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":requested_range_not_satisfiable" + } + } + }, + "417":{ + "code":"417", + "title":"Expectation Failed", + "summary":"server cannot meet requirements of Expect request-header field", + "descriptions":{ + "wikipedia":{ + "body":"The server cannot meet the requirements of the Expect request-header field.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#417" + }, + "ietf":{ + "body":"The expectation given in an Expect request-header field could not be met by this server, or, if the server is a proxy, the server has unambiguous evidence that the request could not be met by the next-hop server.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":expectation_failed" + } + } + }, + "418":{ + "code":"418", + "title":"I'm a teapot (RFC 2324)", + "summary":"I'm a teapot", + "descriptions":{ + "wikipedia":{ + "body":"This code was defined in 1998 as one of the traditional IETF April Fools' jokes, in RFC 2324, Hyper Text Coffee Pot Control Protocol, and is not expected to be implemented by actual HTTP servers. However, known implementations do exist. An Nginx HTTP server uses this code to simulate goto-like behaviour in its configuration.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#418" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":\"i'm_a_teapot\" (explanation<\/a> gist.github.com<\/sup>)<\/small>" + } + } + }, + "420":{ + "code":"420", + "title":"Enhance Your Calm", + "summary":"Twitter rate limiting", + "descriptions":{ + "wikipedia":{ + "body":"Returned by the Twitter Search and Trends API when the client is being rate limited.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#420" + } + } + }, + "422":{ + "code":"422", + "title":"Unprocessable Entity (WebDAV) (RFC 4918)", + "summary":"request unable to be followed due to semantic errors", + "descriptions":{ + "wikipedia":{ + "body":"The request was well-formed but was unable to be followed due to semantic errors.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#422" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":unprocessable_entity" + } + } + }, + "423":{ + "code":"423", + "title":"Locked (WebDAV) (RFC 4918)", + "summary":"resource that is being accessed is locked", + "descriptions":{ + "wikipedia":{ + "body":"The resource that is being accessed is locked.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#423" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":locked" + } + } + }, + "424":{ + "code":"424", + "title":"Failed Dependency (WebDAV) (RFC 4918)", + "summary":"request failed due to failure of a previous request", + "descriptions":{ + "wikipedia":{ + "body":"The request failed due to failure of a previous request (e.g. a PROPPATCH).", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#424" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":failed_dependency" + } + } + }, + "426":{ + "code":"426", + "title":"Upgrade Required (RFC 2817)", + "summary":"client should switch to a different protocol", + "descriptions":{ + "wikipedia":{ + "body":"The client should switch to a different protocol such as TLS\/1.0.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#426" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":upgrade_required" + } + } + }, + "428":{ + "code":"428", + "title":"Precondition Required", + "summary":"origin server requires the request to be conditional", + "descriptions":{ + "wikipedia":{ + "body":"The origin server requires the request to be conditional. Intended to prevent \"the 'lost update' problem, where a client GETs a resource's state, modifies it, and PUTs it back to the server, when meanwhile a third party has modified the state on the server, leading to a conflict.\" Proposed in an Internet-Draft.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#428" + } + } + }, + "429":{ + "code":"429", + "title":"Too Many Requests", + "summary":"user has sent too many requests in a given amount of time", + "descriptions":{ + "wikipedia":{ + "body":"The user has sent too many requests in a given amount of time. Intended for use with rate limiting schemes. Proposed in an Internet-Draft.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#429" + } + } + }, + "431":{ + "code":"431", + "title":"Request Header Fields Too Large", + "summary":"server is unwilling to process the request", + "descriptions":{ + "wikipedia":{ + "body":"The server is unwilling to process the request because either an individual header field, or all the header fields collectively, are too large. Proposed in an Internet-Draft.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#431" + } + } + }, + "444":{ + "code":"444", + "title":"No Response", + "summary":"server returns no information and closes the connection", + "descriptions":{ + "wikipedia":{ + "body":"An nginx HTTP server extension. The server returns no information to the client and closes the connection (useful as a deterrent for malware).", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#444" + } + } + }, + "449":{ + "code":"449", + "title":"Retry With", + "summary":"request should be retried after performing action", + "descriptions":{ + "wikipedia":{ + "body":"A Microsoft extension. The request should be retried after performing the appropriate action.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#449" + } + } + }, + "450":{ + "code":"450", + "title":"Blocked by Windows Parental Controls", + "summary":"Windows Parental Controls blocking access to webpage", + "descriptions":{ + "wikipedia":{ + "body":"A Microsoft extension. This error is given when Windows Parental Controls are turned on and are blocking access to the given webpage.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#450" + } + } + }, + "451":{ + "code":"451", + "title":"Wrong Exchange server", + "summary":"The server cannot reach the client's mailbox.", + "descriptions":{ + "MS-ASHTTP":{ + "body":"If the client is attempting to connect to the wrong server (that is, a server that cannot access the user's mailbox), or if there is a more efficient server to use to reach the user's mailbox, then a 451 Redirect error is returned.", + "link":"http://msdn.microsoft.com/en-us/library/gg651019" + } + } + }, + "499":{ + "code":"499", + "title":"Client Closed Request", + "summary":"connection closed by client while HTTP server is processing", + "descriptions":{ + "wikipedia":{ + "body":"An Nginx HTTP server extension. This code is introduced to log the case when the connection is closed by client while HTTP server is processing its request, making server unable to send the HTTP header back.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#499" + } + } + } + } +} \ No newline at end of file diff --git a/scripts/codes/5.json b/scripts/codes/5.json new file mode 100644 index 0000000000..96efbffff7 --- /dev/null +++ b/scripts/codes/5.json @@ -0,0 +1,234 @@ +{ + "class":{ + "title":"Server Error", + "class":"5" + }, + "codes":{ + "500":{ + "code":"500", + "title":"Internal Server Error", + "summary":"generic error message", + "descriptions":{ + "wikipedia":{ + "body":"A generic error message, given when no more specific message is suitable.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#500" + }, + "ietf":{ + "body":"The server encountered an unexpected condition which prevented it from fulfilling the request.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":internal_server_error" + } + } + }, + "501":{ + "code":"501", + "title":"Not Implemented", + "summary":"server does not recognise method or lacks ability to fulfill", + "descriptions":{ + "wikipedia":{ + "body":"The server either does not recognise the request method, or it lacks the ability to fulfill the request.[2]", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#501" + }, + "ietf":{ + "body":"The server does not support the functionality required to fulfill the request. This is the appropriate response when the server does not recognize the request method and is not capable of supporting it for any resource.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":not_implemented" + } + } + }, + "502":{ + "code":"502", + "title":"Bad Gateway", + "summary":"server received an invalid response from upstream server", + "descriptions":{ + "wikipedia":{ + "body":"The server was acting as a gateway or proxy and received an invalid response from the upstream server.[2]", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#502" + }, + "ietf":{ + "body":"The server, while acting as a gateway or proxy, received an invalid response from the upstream server it accessed in attempting to fulfill the request.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":bad_gateway" + } + } + }, + "503":{ + "code":"503", + "title":"Service Unavailable", + "summary":"server is currently unavailable", + "descriptions":{ + "wikipedia":{ + "body":"The server is currently unavailable (because it is overloaded or down for maintenance).[2] Generally, this is a temporary state.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#503" + }, + "ietf":{ + "body":"The server is currently unable to handle the request due to a temporary overloading or maintenance of the server. The implication is that this is a temporary condition which will be alleviated after some delay. If known, the length of the delay MAY be indicated in a Retry-After header. If no Retry-After is given, the client SHOULD handle the response as it would for a 500 response.\r\nNote: The existence of the 503 status code does not imply that a server must use it when becoming overloaded. Some servers may wish to simply refuse the connection.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":service_unavailable" + } + } + }, + "504":{ + "code":"504", + "title":"Gateway Timeout", + "summary":"gateway did not receive response from upstream server", + "descriptions":{ + "wikipedia":{ + "body":"The server was acting as a gateway or proxy and did not receive a timely response from the upstream server.[2]", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#504" + }, + "ietf":{ + "body":"The server, while acting as a gateway or proxy, did not receive a timely response from the upstream server specified by the URI (e.g. HTTP, FTP, LDAP) or some other auxiliary server (e.g. DNS) it needed to access in attempting to complete the request.\r\nNote: Note to implementors: some deployed proxies are known to return 400 or 500 when DNS lookups time out.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":gateway_timeout" + } + } + }, + "505":{ + "code":"505", + "title":"HTTP Version Not Supported", + "summary":"server does not support the HTTP protocol version", + "descriptions":{ + "wikipedia":{ + "body":"The server does not support the HTTP protocol version used in the request.[2]", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#505" + }, + "ietf":{ + "body":"The server does not support, or refuses to support, the HTTP protocol version that was used in the request message. The server is indicating that it is unable or unwilling to complete the request using the same major version as the client. The response SHOULD contain an entity describing why that version is not supported and what other protocols are supported by that server.", + "link":"http:\/\/www.ietf.org\/rfc\/rfc2616.txt" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":http_version_not_supported" + } + } + }, + "506":{ + "code":"506", + "title":"Variant Also Negotiates (RFC 2295)", + "summary":"content negotiation for the request results in a circular reference", + "descriptions":{ + "wikipedia":{ + "body":"Transparent content negotiation for the request results in a circular reference.[23]", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#506" + } + } + }, + "507":{ + "code":"507", + "title":"Insufficient Storage (WebDAV) (RFC 4918)", + "summary":"server is unable to store the representation", + "descriptions":{ + "wikipedia":{ + "body":"The server is unable to store the representation needed to complete the request.[7]", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#507" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":insufficient_storage" + } + } + }, + "508":{ + "code":"508", + "title":"Loop Detected (WebDAV) (RFC 5842)", + "summary":"server detected an infinite loop while processing the request", + "descriptions":{ + "wikipedia":{ + "body":"The server detected an infinite loop while processing the request (sent in lieu of 208).", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#508" + } + } + }, + "509":{ + "code":"509", + "title":"Bandwidth Limit Exceeded (Apache bw\/limited extension)", + "summary":"bandwidth limit exceeded", + "descriptions":{ + "wikipedia":{ + "body":"This status code, while used by many servers, is not specified in any RFCs.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#509" + } + } + }, + "510":{ + "code":"510", + "title":"Not Extended (RFC 2774)", + "summary":"further extensions to the request are required", + "descriptions":{ + "wikipedia":{ + "body":"Further extensions to the request are required for the server to fulfill it.[24]", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#510" + } + }, + "references":{ + "rails":{ + "title":"Rails HTTP Status Symbol", + "value":":not_extended" + } + } + }, + "511":{ + "code":"511", + "title":"Network Authentication Required", + "summary":"client needs to authenticate to gain network access", + "descriptions":{ + "wikipedia":{ + "body":"The client needs to authenticate to gain network access. Intended for use by intercepting proxies used to control access to the network (e.g. \"captive portals\" used to require agreement to Terms of Service before granting full Internet access via a Wi-Fi hotspot). Proposed in an Internet-Draft.[19]", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#511" + } + } + }, + "598":{ + "code":"598", + "title":"Network read timeout error", + "summary":"network read timeout behind the proxy ", + "descriptions":{ + "wikipedia":{ + "body":"This status code is not specified in any RFCs, but is used by some HTTP proxies to signal a network read timeout behind the proxy to a client in front of the proxy.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#598" + } + } + }, + "599":{ + "code":"599", + "title":"Network connect timeout error", + "summary":"network connect timeout behind the proxy", + "descriptions":{ + "wikipedia":{ + "body":"This status code is not specified in any RFCs, but is used by some HTTP proxies to signal a network connect timeout behind the proxy to a client in front of the proxy.", + "link":"http:\/\/en.wikipedia.org\/wiki\/List_of_HTTP_status_codes#599" + } + } + } + } +} \ No newline at end of file diff --git a/scripts/codes/LICENSE b/scripts/codes/LICENSE new file mode 100644 index 0000000000..040932d5fa --- /dev/null +++ b/scripts/codes/LICENSE @@ -0,0 +1,18 @@ +Copyright (C) 2012 - 2013 Samuel Ryan (citricsquid) + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the +Software, and to permit persons to whom the Software is furnished to do so, +subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. \ No newline at end of file diff --git a/scripts/generate.ml b/scripts/generate.ml new file mode 100644 index 0000000000..2b3c12bf41 --- /dev/null +++ b/scripts/generate.ml @@ -0,0 +1,1827 @@ +(* + * Copyright (c) 2013 Thomas Gazagnaire + * + * Permission to use, copy, modify, and distribute this software for any + * purpose with or without fee is hereby granted, provided that the above + * copyright notice and this permission notice appear in all copies. + * + * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES + * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF + * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR + * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES + * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN + * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF + * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. + *) + +module Uutf = struct + +(*--------------------------------------------------------------------------- + Copyright 2012 Daniel C. Bünzli. All rights reserved. + Distributed under the BSD3 license, see license at the end of the file. + %%NAME%% release %%VERSION%% + ---------------------------------------------------------------------------*) + +let io_buffer_size = 65536 (* IO_BUFFER_SIZE 4.0.0 *) + +let pp = Format.fprintf +let invalid_encode () = invalid_arg "expected `Await encode" +let invalid_bounds j l = + invalid_arg (Printf.sprintf "invalid bounds (index %d, length %d)" j l) + +(* Unsafe string byte manipulations. If you don't believe the author's + invariants, replacing with safe versions makes everything safe in + the module. He won't be upset. *) + +let unsafe_chr = Char.unsafe_chr +let unsafe_blit = String.unsafe_blit +let unsafe_array_get = Array.unsafe_get +let unsafe_byte s j = Char.code (String.unsafe_get s j) +let unsafe_set_byte s j byte = String.unsafe_set s j (Char.unsafe_chr byte) + +(* Unicode characters *) + +type uchar = int +let u_bom = 0xFEFF (* BOM. *) +let u_rep = 0xFFFD (* replacement character. *) +let is_uchar cp = + (0x0000 <= cp && cp <= 0xD7FF) || (0xE000 <= cp && cp <= 0x10FFFF) + +let pp_cp ppf cp = + if cp < 0 || cp > 0x10FFFF then pp ppf "U+Invalid(%X)" cp else + if cp <= 0xFFFF then pp ppf "U+%04X" cp else + pp ppf "U+%X" cp + +let cp_to_string cp = (* NOT thread safe. *) + pp Format.str_formatter "%a" pp_cp cp; Format.flush_str_formatter () + +(* Unicode encoding schemes *) + +type encoding = [ `UTF_8 | `UTF_16 | `UTF_16BE | `UTF_16LE ] +type decoder_encoding = [ encoding | `US_ASCII | `ISO_8859_1 ] + +let encoding_of_string s = match String.uppercase s with (* IANA names. *) +| "UTF-8" -> Some `UTF_8 +| "UTF-16" -> Some `UTF_16 +| "UTF-16LE" -> Some `UTF_16LE +| "UTF-16BE" -> Some `UTF_16BE +| "ANSI_X3.4-1968" | "ISO-IR-6" | "ANSI_X3.4-1986" | "ISO_646.IRV:1991" +| "ASCII" | "ISO646-US" | "US-ASCII" | "US" | "IBM367" | "CP367" | "CSASCII" -> + Some `US_ASCII +| "ISO_8859-1:1987" | "ISO-IR-100" | "ISO_8859-1" | "ISO-8859-1" +| "LATIN1" | "L1" | "IBM819" | "CP819" | "CSISOLATIN1" -> + Some `ISO_8859_1 +| _ -> None + +let encoding_to_string = function +| `UTF_8 -> "UTF-8" | `UTF_16 -> "UTF-16" | `UTF_16BE -> "UTF-16BE" +| `UTF_16LE -> "UTF-16LE" | `US_ASCII -> "US-ASCII" +| `ISO_8859_1 -> "ISO-8859-1" + +(* Base character decoders. They assume enough data. *) + +let malformed s j l = `Malformed (String.sub s j l) +let malformed_pair be hi s j l = (* missing or half low surrogate at eoi. *) + let bs1 = String.sub s j l in + let bs0 = String.create 2 in + let j0, j1 = if be then (0, 1) else (1, 0) in + unsafe_set_byte bs0 j0 (hi lsr 8); + unsafe_set_byte bs0 j1 (hi land 0xFF); + `Malformed (bs0 ^ bs1) + +let r_us_ascii s j = + (* assert (0 <= j && j < String.length s); *) + let b0 = unsafe_byte s j in + if b0 <= 127 then `Uchar b0 else malformed s j 1 + +let r_iso_8859_1 s j = + (* assert (0 <= j && j < String.length s); *) + `Uchar (unsafe_byte s j) + +let utf_8_len = [| (* uchar byte length according to first UTF-8 byte. *) + 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; + 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; + 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; + 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; + 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; 1; + 1; 1; 1; 1; 1; 1; 1; 1; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; + 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; + 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; + 0; 0; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; 2; + 2; 2; 2; 2; 2; 2; 2; 2; 3; 3; 3; 3; 3; 3; 3; 3; 3; 3; 3; 3; 3; 3; 3; 3; + 4; 4; 4; 4; 4; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0; 0 |] + +let r_utf_8 s j l = + (* assert (0 <= j && 0 <= l && j + l <= String.length s); *) + match l with + | 1 -> `Uchar (unsafe_byte s j) + | 2 -> + let b0 = unsafe_byte s j in let b1 = unsafe_byte s (j + 1) in + if b1 lsr 6 != 0b10 then malformed s j l else + `Uchar (((b0 land 0x1F) lsl 6) lor (b1 land 0x3F)) + | 3 -> + let b0 = unsafe_byte s j in let b1 = unsafe_byte s (j + 1) in + let b2 = unsafe_byte s (j + 2) in + let c = `Uchar (((b0 land 0x0F) lsl 12) lor + ((b1 land 0x3F) lsl 6) lor + (b2 land 0x3F)) + in + if b2 lsr 6 != 0b10 then malformed s j l else + begin match b0 with + | 0xE0 -> if b1 < 0xA0 || 0xBF < b1 then malformed s j l else c + | 0xED -> if b1 < 0x80 || 0x9F < b1 then malformed s j l else c + | _ -> if b1 lsr 6 != 0b10 then malformed s j l else c + end + | 4 -> + let b0 = unsafe_byte s j in let b1 = unsafe_byte s (j + 1) in + let b2 = unsafe_byte s (j + 2) in let b3 = unsafe_byte s (j + 3) in + let c = `Uchar (((b0 land 0x07) lsl 18) lor + ((b1 land 0x3F) lsl 12) lor + ((b2 land 0x3F) lsl 6) lor + (b3 land 0x3F)) + in + if b3 lsr 6 != 0b10 || b2 lsr 6 != 0b10 then malformed s j l else + begin match b0 with + | 0xF0 -> if b1 < 0x90 || 0xBF < b1 then malformed s j l else c + | 0xF4 -> if b1 < 0x80 || 0x8F < b1 then malformed s j l else c + | _ -> if b1 lsr 6 != 0b10 then malformed s j l else c + end + | _ -> assert false + +let r_utf_16 s j0 j1 = (* May return a high surrogate. *) + (* assert (0 <= j0 && 0 <= j1 && max j0 j1 < String.length s); *) + let b0 = unsafe_byte s j0 in let b1 = unsafe_byte s j1 in + let u = (b0 lsl 8) lor b1 in + if u < 0xD800 || u > 0xDFFF then `Uchar u else + if u > 0xDBFF then malformed s (min j0 j1) 2 else `Hi u + +let r_utf_16_lo hi s j0 j1 = (* Combines [hi] with a low surrogate. *) + (* assert (0 <= j0 && 0 <= j1 && max j0 j1 < String.length s); *) + let b0 = unsafe_byte s j0 in + let b1 = unsafe_byte s j1 in + let lo = (b0 lsl 8) lor b1 in + if lo < 0xDC00 || lo > 0xDFFF + then malformed_pair (j0 < j1 (* true => be *)) hi s (min j0 j1) 2 + else `Uchar ((((hi land 0x3FF) lsl 10) lor (lo land 0x3FF)) + 0x10000) + +let r_encoding s j l = (* guess encoding with max. 3 bytes. *) + (* assert (0 <= j && 0 <= l && j + l <= String.length s) *) + let some i = if i < l then Some (unsafe_byte s (j + i)) else None in + match (some 0), (some 1), (some 2) with + | Some 0xEF, Some 0xBB, Some 0xBF -> `UTF_8 `BOM + | Some 0xFE, Some 0xFF, _ -> `UTF_16BE `BOM + | Some 0xFF, Some 0xFE, _ -> `UTF_16LE `BOM + | Some 0x00, Some p, _ when p > 0 -> `UTF_16BE (`ASCII p) + | Some p, Some 0x00, _ when p > 0 -> `UTF_16LE (`ASCII p) + | Some u, _, _ when utf_8_len.(u) <> 0 -> `UTF_8 `Decode + | Some _, Some _, _ -> `UTF_16BE `Decode + | Some _, None , None -> `UTF_8 `Decode + | None , None , None -> `UTF_8 `End + | None , Some _, _ -> assert false + | Some _, None , Some _ -> assert false + | None , None , Some _ -> assert false + +(* Decode *) + +type src = [ `Channel of in_channel | `String of string | `Manual ] +type nln = [ `ASCII of uchar | `NLF of uchar | `Readline of uchar ] +type decode = [ `Await | `End | `Malformed of string | `Uchar of uchar] + +let pp_decode ppf = function +| `Uchar u -> pp ppf "@[`Uchar %a@]" pp_cp u +| `End -> pp ppf "`End" +| `Await -> pp ppf "`Await" +| `Malformed bs -> + let l = String.length bs in + pp ppf "@[`Malformed @[("; + if l > 0 then pp ppf "%02X" (Char.code (bs.[0])); + for i = 1 to l - 1 do pp ppf " %02X" (Char.code (bs.[i])) done; + pp ppf ")@]@]" + +type decoder = + { src : src; (* input source. *) + mutable encoding : decoder_encoding; (* decoded encoding. *) + nln : nln option; (* newline normalization (if any). *) + nl : int; (* newline normalization character. *) + mutable i : string; (* current input chunk. *) + mutable i_pos : int; (* input current position. *) + mutable i_max : int; (* input maximal position. *) + t : string; (* four bytes temporary buffer for overlapping reads. *) + mutable t_len : int; (* current byte length of [t]. *) + mutable t_need : int; (* number of bytes needed in [t]. *) + mutable removed_bom : bool; (* [true] if an initial BOM was removed. *) + mutable last_cr : bool; (* [true] if last char was CR. *) + mutable line : int; (* line number. *) + mutable col : int; (* column number. *) + mutable count : int; (* char count. *) + mutable pp : (* decoder post-processor for BOM, position and nln. *) + decoder -> [ `Malformed of string | `Uchar of uchar ] -> decode; + mutable k : decoder -> decode } (* decoder continuation. *) + +(* On decodes that overlap two (or more) [d.i] buffers, we use [t_fill] to copy + the input data to [d.t] and decode from there. If the [d.i] buffers are not + too small this is faster than continuation based byte per byte writes. + + End of input (eoi) is signalled by [d.i_pos = 0] and [d.i_max = min_int] + which implies that [i_rem d < 0] is [true]. *) + +let i_rem d = d.i_max - d.i_pos + 1 (* remaining bytes to read in [d.i]. *) +let eoi d = d.i <- ""; d.i_pos <- 0; d.i_max <- min_int (* set eoi in [d]. *) +let src d s j l = (* set [d.i] with [s]. *) + if (j < 0 || l < 0 || j + l > String.length s) then invalid_bounds j l else + if (l = 0) then eoi d else + (d.i <- s; d.i_pos <- j; d.i_max <- j + l - 1) + +let refill k d = match d.src with (* get new input in [d.i] and [k]ontinue. *) +| `Manual -> d.k <- k; `Await +| `String _ -> eoi d; k d +| `Channel ic -> + let rc = input ic d.i 0 (String.length d.i) in + (src d d.i 0 rc; k d) + +let t_need d need = d.t_len <- 0; d.t_need <- need +let rec t_fill k d = (* get [d.t_need] bytes (or less if eoi) in [i.t]. *) + let blit d l = + unsafe_blit d.i d.i_pos d.t d.t_len (* write pos. *) l; + d.i_pos <- d.i_pos + l; d.t_len <- d.t_len + l; + in + let rem = i_rem d in + if rem < 0 (* eoi *) then k d else + let need = d.t_need - d.t_len in + if rem < need then (blit d rem; refill (t_fill k) d) else (blit d need; k d) + +let ret k v d = d.k <- k; d.pp d v (* return post-processed [v]. *) + +(* Decoders. *) + +let rec decode_us_ascii d = + let rem = i_rem d in + if rem <= 0 then (if rem < 0 then `End else refill decode_us_ascii d) else + let j = d.i_pos in + d.i_pos <- d.i_pos + 1; ret decode_us_ascii (r_us_ascii d.i j) d + +let rec decode_iso_8859_1 d = + let rem = i_rem d in + if rem <= 0 then (if rem < 0 then `End else refill decode_iso_8859_1 d) else + let j = d.i_pos in + d.i_pos <- d.i_pos + 1; ret decode_iso_8859_1 (r_iso_8859_1 d.i j) d + +(* UTF-8 decoder *) + +let rec t_decode_utf_8 d = (* decode from [d.t]. *) + if d.t_len < d.t_need + then ret decode_utf_8 (malformed d.t 0 d.t_len) d + else ret decode_utf_8 (r_utf_8 d.t 0 d.t_len) d + +and decode_utf_8 d = + let rem = i_rem d in + if rem <= 0 then (if rem < 0 then `End else refill decode_utf_8 d) else + let need = unsafe_array_get utf_8_len (unsafe_byte d.i d.i_pos) in + if rem < need then (t_need d need; t_fill t_decode_utf_8 d) else + let j = d.i_pos in + if need = 0 + then (d.i_pos <- d.i_pos + 1; ret decode_utf_8 (malformed d.i j 1) d) + else (d.i_pos <- d.i_pos + need; ret decode_utf_8 (r_utf_8 d.i j need) d) + +(* UTF-16BE decoder *) + +let rec t_decode_utf_16be_lo hi d = (* decode from [d.t]. *) + if d.t_len < d.t_need + then ret decode_utf_16be (malformed_pair true hi d.t 0 d.t_len) d + else ret decode_utf_16be (r_utf_16_lo hi d.t 0 1) d + +and t_decode_utf_16be d = (* decode from [d.t]. *) + if d.t_len < d.t_need + then ret decode_utf_16be (malformed d.t 0 d.t_len) d + else decode_utf_16be_lo (r_utf_16 d.t 0 1) d + +and decode_utf_16be_lo v d = match v with +| `Uchar _ | `Malformed _ as v -> ret decode_utf_16be v d +| `Hi hi -> + let rem = i_rem d in + if rem < 2 then (t_need d 2; t_fill (t_decode_utf_16be_lo hi) d) else + let j = d.i_pos in + d.i_pos <- d.i_pos + 2; ret decode_utf_16be (r_utf_16_lo hi d.i j (j + 1)) d + +and decode_utf_16be d = + let rem = i_rem d in + if rem <= 0 then (if rem < 0 then `End else refill decode_utf_16be d) else + if rem < 2 then (t_need d 2; t_fill t_decode_utf_16be d) else + let j = d.i_pos in + d.i_pos <- d.i_pos + 2; decode_utf_16be_lo (r_utf_16 d.i j (j + 1)) d + +(* UTF-16LE decoder, same as UTF-16BE with byte swapped. *) + +let rec t_decode_utf_16le_lo hi d = (* decode from [d.t]. *) + if d.t_len < d.t_need + then ret decode_utf_16le (malformed_pair false hi d.t 0 d.t_len) d + else ret decode_utf_16le (r_utf_16_lo hi d.t 1 0) d + +and t_decode_utf_16le d = (* decode from [d.t]. *) + if d.t_len < d.t_need + then ret decode_utf_16le (malformed d.t 0 d.t_len) d + else decode_utf_16le_lo (r_utf_16 d.t 1 0) d + +and decode_utf_16le_lo v d = match v with +| `Uchar _ | `Malformed _ as v -> ret decode_utf_16le v d +| `Hi hi -> + let rem = i_rem d in + if rem < 2 then (t_need d 2; t_fill (t_decode_utf_16le_lo hi) d) else + let j = d.i_pos in + d.i_pos <- d.i_pos + 2; ret decode_utf_16le (r_utf_16_lo hi d.i (j + 1) j) d + +and decode_utf_16le d = + let rem = i_rem d in + if rem <= 0 then (if rem < 0 then `End else refill decode_utf_16le d) else + if rem < 2 then (t_need d 2; t_fill t_decode_utf_16le d) else + let j = d.i_pos in + d.i_pos <- d.i_pos + 2; decode_utf_16le_lo (r_utf_16 d.i (j + 1) j) d + +(* Encoding guessing. The guess is simple but starting the decoder + after is tedious, uutf's decoders are not designed to put bytes + back in the stream. *) + +let guessed_utf_8 d = (* start decoder after `UTF_8 guess. *) + let b3 d = (* handles the third read byte. *) + let b3 = unsafe_byte d.t 2 in + match utf_8_len.(b3) with + | 0 -> ret decode_utf_8 (malformed d.t 2 1) d + | n -> + d.t_need <- n; d.t_len <- 1; unsafe_set_byte d.t 0 b3; + t_fill t_decode_utf_8 d + in + let b2 d = (* handle second read byte. *) + let b2 = unsafe_byte d.t 1 in + let b3 = if d.t_len > 2 then b3 else decode_utf_8 (* decodes `End *) in + match utf_8_len.(b2) with + | 0 -> ret b3 (malformed d.t 1 1) d + | 1 -> ret b3 (r_utf_8 d.t 1 1) d + | n -> (* copy d.t.(1-2) to d.t.(0-1) and decode *) + d.t_need <- n; + unsafe_set_byte d.t 0 b2; + if (d.t_len < 3) then d.t_len <- 1 else + (d.t_len <- 2; unsafe_set_byte d.t 1 (unsafe_byte d.t 2); ); + t_fill t_decode_utf_8 d + in + let b1 = unsafe_byte d.t 0 in (* handle first read byte. *) + let b2 = if d.t_len > 1 then b2 else decode_utf_8 (* decodes `End *) in + match utf_8_len.(b1) with + | 0 -> ret b2 (malformed d.t 0 1) d + | 1 -> ret b2 (r_utf_8 d.t 0 1) d + | 2 -> + if d.t_len < 2 then ret decode_utf_8 (malformed d.t 0 1) d else + if d.t_len < 3 then ret decode_utf_8 (r_utf_8 d.t 0 2) d else + ret b3 (r_utf_8 d.t 0 2) d + | 3 -> + if d.t_len < 3 then ret decode_utf_8 (malformed d.t 0 d.t_len) d else + ret decode_utf_8 (r_utf_8 d.t 0 3) d + | 4 -> + if d.t_len < 3 then ret decode_utf_8 (malformed d.t 0 d.t_len) d else + (d.t_need <- 4; t_fill t_decode_utf_8 d) + | n -> assert false + +let guessed_utf_16 d be v = (* start decoder after `UTF_16{BE,LE} guess. *) + let decode_utf_16, t_decode_utf_16, t_decode_utf_16_lo, j0, j1 = + if be then decode_utf_16be, t_decode_utf_16be, t_decode_utf_16be_lo, 0, 1 + else decode_utf_16le, t_decode_utf_16le, t_decode_utf_16le_lo, 1, 0 + in + let b3 k d = + if d.t_len < 3 then decode_utf_16 d (* decodes `End *) else + begin (* copy d.t.(2) to d.t.(0) and decode. *) + d.t_need <- 2; d.t_len <- 1; + unsafe_set_byte d.t 0 (unsafe_byte d.t 2); + t_fill k d + end + in + match v with + | `BOM -> ret (b3 t_decode_utf_16) (`Uchar u_bom) d + | `ASCII u -> ret (b3 t_decode_utf_16) (`Uchar u) d + | `Decode -> + match r_utf_16 d.t j0 j1 with + | `Malformed _ | `Uchar _ as v -> ret (b3 t_decode_utf_16) v d + | `Hi hi -> + if d.t_len < 3 then ret decode_utf_16 (malformed_pair be hi "" 0 0) d + else (b3 (t_decode_utf_16_lo hi)) d + +let guess_encoding d = (* guess encoding and start decoder. *) + let setup d = match r_encoding d.t 0 d.t_len with + | `UTF_8 r -> + d.encoding <- `UTF_8; d.k <- decode_utf_8; + begin match r with + | `BOM -> ret decode_utf_8 (`Uchar u_bom) d + | `Decode -> guessed_utf_8 d + | `End -> `End + end + | `UTF_16BE r -> + d.encoding <- `UTF_16BE; d.k <- decode_utf_16be; guessed_utf_16 d true r + | `UTF_16LE r -> + d.encoding <- `UTF_16LE; d.k <- decode_utf_16le; guessed_utf_16 d false r + + in + (t_need d 3; t_fill setup d) + +(* Character post-processors. Used for BOM handling, newline + normalization and position tracking. The [pp_remove_bom] is only + used for the first character to remove a possible initial BOM and + handle UTF-16 endianness recognition. *) + +let nline d = d.col <- 0; d.line <- d.line + 1 (* inlined. *) +let ncol d = d.col <- d.col + 1 (* inlined. *) +let ncount d = d.count <- d.count + 1 (* inlined. *) +let cr d b = d.last_cr <- b (* inlined. *) + +let pp_remove_bom utf16 pp d = function(* removes init. BOM, handles UTF-16. *) +| `Uchar 0xFEFF (* BOM *) -> + if utf16 then (d.encoding <- `UTF_16BE; d.k <- decode_utf_16be); + d.removed_bom <- true; d.pp <- pp; d.k d +| `Uchar 0xFFFE (* BOM reversed from decode_utf_16be *) when utf16 -> + d.encoding <- `UTF_16LE; d.k <- decode_utf_16le; + d.removed_bom <- true; d.pp <- pp; d.k d +| `Malformed _ | `Uchar _ as v -> + d.removed_bom <- false; d.pp <- pp; d.pp d v + +let pp_nln_none d = function +| `Uchar 0x000A (* LF *) as v -> + let last_cr = d.last_cr in + cr d false; ncount d; if last_cr then v else (nline d; v) +| `Uchar 0x000D (* CR *) as v -> cr d true; ncount d; nline d; v +| `Uchar (0x0085 | 0x000C | 0x2028 | 0x2029) (* NEL | FF | LS | PS *) as v -> + cr d false; ncount d; nline d; v +| `Uchar _ | `Malformed _ as v -> cr d false; ncount d; ncol d; v + +let pp_nln_readline d = function +| `Uchar 0x000A (* LF *) -> + let last_cr = d.last_cr in + cr d false; if last_cr then d.k d else (ncount d; nline d; `Uchar d.nl) +| `Uchar 0x000D (* CR *) -> cr d true; ncount d; nline d; `Uchar d.nl +| `Uchar (0x0085 | 0x000C | 0x2028 | 0x2029) (* NEL | FF | LS | PS *) -> + cr d false; ncount d; nline d; `Uchar d.nl +| `Uchar _ | `Malformed _ as v -> cr d false; ncount d; ncol d; v + +let pp_nln_nlf d = function +| `Uchar 0x000A (* LF *) -> + let last_cr = d.last_cr in + cr d false; if last_cr then d.k d else (ncount d; nline d; `Uchar d.nl) +| `Uchar 0x000D (* CR *) -> cr d true; ncount d; nline d; `Uchar d.nl +| `Uchar 0x0085 (* NEL *) -> cr d false; ncount d; nline d; `Uchar d.nl +| `Uchar (0x000C | 0x2028 | 0x2029) as v (* FF | LS | PS *) -> + cr d false; ncount d; nline d; v +| `Uchar _ | `Malformed _ as v -> cr d false; ncount d; ncol d; v + +let pp_nln_ascii d = function +| `Uchar 0x000A (* LF *) -> + let last_cr = d.last_cr in + cr d false; if last_cr then d.k d else (ncount d; nline d; `Uchar d.nl) +| `Uchar 0x000D (* CR *) -> cr d true; ncount d; nline d; `Uchar d.nl +| `Uchar (0x0085 | 0x000C | 0x2028 | 0x2029) as v (* NEL | FF | LS | PS *) -> + cr d false; ncount d; nline d; v +| `Uchar _ | `Malformed _ as v -> cr d false; ncount d; ncol d; v + +let decode_fun = function +| `UTF_8 -> decode_utf_8 +| `UTF_16 -> decode_utf_16be (* see [pp_remove_bom]. *) +| `UTF_16BE -> decode_utf_16be +| `UTF_16LE -> decode_utf_16le +| `US_ASCII -> decode_us_ascii +| `ISO_8859_1 -> decode_iso_8859_1 + +let decoder ?nln ?encoding src = + let pp, nl = match nln with + | None -> pp_nln_none, 0x000A (* not used. *) + | Some (`ASCII nl) -> pp_nln_ascii, nl + | Some (`NLF nl) -> pp_nln_nlf, nl + | Some (`Readline nl) -> pp_nln_readline, nl + in + let encoding, k = match encoding with + | None -> `UTF_8, guess_encoding + | Some e -> (e :> decoder_encoding), decode_fun e + in + let i, i_pos, i_max = match src with + | `Manual -> "", 1, 0 (* implies src_rem d = 0. *) + | `Channel _ -> String.create io_buffer_size, 1, 0 (* idem. *) + | `String s -> s, 0, String.length s - 1 + in + { src = (src :> src); encoding; nln = (nln :> nln option); nl; + i; i_pos; i_max; t = String.create 4; t_len = 0; t_need = 0; + removed_bom = false; last_cr = false; line = 1; col = 0; count = 0; + pp = pp_remove_bom (encoding = `UTF_16) pp; k } + +let decode d = d.k d +let decoder_line d = d.line +let decoder_col d = d.col +let decoder_count d = d.count +let decoder_removed_bom d = d.removed_bom +let decoder_src d = d.src +let decoder_nln d = d.nln +let decoder_encoding d = d.encoding +let set_decoder_encoding d e = + d.encoding <- (e :> decoder_encoding); d.k <- decode_fun e + +(* Encode *) + +type dst = [ `Channel of out_channel | `Buffer of Buffer.t | `Manual ] +type encode = [ `Await | `End | `Uchar of uchar ] +type encoder = + { dst : dst; (* output destination. *) + encoding : encoding; (* encoded encoding. *) + mutable o : string; (* current output chunk. *) + mutable o_pos : int; (* next output position to write. *) + mutable o_max : int; (* maximal output position to write. *) + t : string; (* four bytes buffer for overlapping writes. *) + mutable t_pos : int; (* next position to read in [t]. *) + mutable t_max : int; (* maximal position to read in [t]. *) + mutable k : (* encoder continuation. *) + encoder -> encode -> [ `Ok | `Partial ] } + +(* On encodes that overlap two (or more) [e.o] buffers, we encode the + character to the temporary buffer [o.t] and continue with + [tmp_flush] to write this data on the different [e.o] buffers. If + the [e.o] buffers are not too small this is faster than + continuation based byte per byte writes. *) + +let o_rem e = e.o_max - e.o_pos + 1 (* remaining bytes to write in [e.o]. *) +let dst e s j l = (* set [e.o] with [s]. *) + if (j < 0 || l < 0 || j + l > String.length s) then invalid_bounds j l; + e.o <- s; e.o_pos <- j; e.o_max <- j + l - 1 + +let partial k e = function `Await -> k e | `Uchar _ | `End -> invalid_encode () +let flush k e = match e.dst with(* get free storage in [d.o] and [k]ontinue. *) +| `Manual -> e.k <- partial k; `Partial +| `Buffer b -> Buffer.add_substring b e.o 0 e.o_pos; e.o_pos <- 0; k e +| `Channel oc -> output oc e.o 0 e.o_pos; e.o_pos <- 0; k e + +let t_range e max = e.t_pos <- 0; e.t_max <- max +let rec t_flush k e = (* flush [d.t] up to [d.t_max] in [d.i]. *) + let blit e l = + unsafe_blit e.t e.t_pos e.o e.o_pos l; + e.o_pos <- e.o_pos + l; e.t_pos <- e.t_pos + l + in + let rem = o_rem e in + let len = e.t_max - e.t_pos + 1 in + if rem < len then (blit e rem; flush (t_flush k) e) else (blit e len; k e) + +(* Encoders. *) + +let rec encode_utf_8 e v = + let k e = e.k <- encode_utf_8; `Ok in + match v with + | `Await -> k e + | `End -> flush k e + | `Uchar u as v -> + let rem = o_rem e in + if u <= 0x007F then + if rem < 1 then flush (fun e -> encode_utf_8 e v) e else + (unsafe_set_byte e.o e.o_pos u; e.o_pos <- e.o_pos + 1; k e) + else if u <= 0x07FF then + begin + let s, j, k = + if rem < 2 then (t_range e 1; e.t, 0, t_flush k) else + let j = e.o_pos in (e.o_pos <- e.o_pos + 2; e.o, j, k) + in + unsafe_set_byte s j (0xC0 lor (u lsr 6)); + unsafe_set_byte s (j + 1) (0x80 lor (u land 0x3F)); + k e + end + else if u <= 0xFFFF then + begin + let s, j, k = + if rem < 3 then (t_range e 2; e.t, 0, t_flush k) else + let j = e.o_pos in (e.o_pos <- e.o_pos + 3; e.o, j, k) + in + unsafe_set_byte s j (0xE0 lor (u lsr 12)); + unsafe_set_byte s (j + 1) (0x80 lor ((u lsr 6) land 0x3F)); + unsafe_set_byte s (j + 2) (0x80 lor (u land 0x3F)); + k e + end + else + begin + let s, j, k = + if rem < 4 then (t_range e 3; e.t, 0, t_flush k) else + let j = e.o_pos in (e.o_pos <- e.o_pos + 4; e.o, j, k) + in + unsafe_set_byte s j (0xF0 lor (u lsr 18)); + unsafe_set_byte s (j + 1) (0x80 lor ((u lsr 12) land 0x3F)); + unsafe_set_byte s (j + 2) (0x80 lor ((u lsr 6) land 0x3F)); + unsafe_set_byte s (j + 3) (0x80 lor (u land 0x3F)); + k e + end + +let rec encode_utf_16be e v = + let k e = e.k <- encode_utf_16be; `Ok in + match v with + | `Await -> k e + | `End -> flush k e + | `Uchar u -> + let rem = o_rem e in + if u < 0x10000 then + begin + let s, j, k = + if rem < 2 then (t_range e 1; e.t, 0, t_flush k) else + let j = e.o_pos in (e.o_pos <- e.o_pos + 2; e.o, j, k) + in + unsafe_set_byte s j (u lsr 8); + unsafe_set_byte s (j + 1) (u land 0xFF); + k e + end else begin + let s, j, k = + if rem < 4 then (t_range e 3; e.t, 0, t_flush k) else + let j = e.o_pos in (e.o_pos <- e.o_pos + 4; e.o, j, k) + in + let u' = u - 0x10000 in + let hi = (0xD800 lor (u' lsr 10)) in + let lo = (0xDC00 lor (u' land 0x3FF)) in + unsafe_set_byte s j (hi lsr 8); + unsafe_set_byte s (j + 1) (hi land 0xFF); + unsafe_set_byte s (j + 2) (lo lsr 8); + unsafe_set_byte s (j + 3) (lo land 0xFF); + k e + end + +let rec encode_utf_16le e v = (* encode_uft_16be with bytes swapped. *) + let k e = e.k <- encode_utf_16le; `Ok in + match v with + | `Await -> k e + | `End -> flush k e + | `Uchar u -> + let rem = o_rem e in + if u < 0x10000 then + begin + let s, j, k = + if rem < 2 then (t_range e 1; e.t, 0, t_flush k) else + let j = e.o_pos in (e.o_pos <- e.o_pos + 2; e.o, j, k) + in + unsafe_set_byte s j (u land 0xFF); + unsafe_set_byte s (j + 1) (u lsr 8); + k e + end + else + begin + let s, j, k = + if rem < 4 then (t_range e 3; e.t, 0, t_flush k) else + let j = e.o_pos in (e.o_pos <- e.o_pos + 4; e.o, j, k) + in + let u' = u - 0x10000 in + let hi = (0xD800 lor (u' lsr 10)) in + let lo = (0xDC00 lor (u' land 0x3FF)) in + unsafe_set_byte s j (hi land 0xFF); + unsafe_set_byte s (j + 1) (hi lsr 8); + unsafe_set_byte s (j + 2) (lo land 0xFF); + unsafe_set_byte s (j + 3) (lo lsr 8); + k e + end + +let encode_fun = function +| `UTF_8 -> encode_utf_8 +| `UTF_16 -> encode_utf_16be +| `UTF_16BE -> encode_utf_16be +| `UTF_16LE -> encode_utf_16le + +let encoder encoding dst = + let o, o_pos, o_max = match dst with + | `Manual -> "", 1, 0 (* implies o_rem e = 0. *) + | `Buffer _ + | `Channel _ -> String.create io_buffer_size, 0, io_buffer_size - 1 + in + { dst = (dst :> dst); encoding = (encoding :> encoding); o; o_pos; o_max; + t = String.create 4; t_pos = 1; t_max = 0; k = encode_fun encoding} + +let encode e v = e.k e (v :> encode) +let encoder_encoding e = e.encoding +let encoder_dst e = e.dst + +(* Manual sources and destinations. *) + +module Manual = struct + let src = src + let dst = dst + let dst_rem = o_rem +end + +(* Strings folders and Buffer encoders *) + +module String = struct + let encoding_guess s = match r_encoding s 0 (max (String.length s) 3) with + | `UTF_8 d -> `UTF_8, (d = `BOM) + | `UTF_16BE d -> `UTF_16BE, (d = `BOM) + | `UTF_16LE d -> `UTF_16LE, (d = `BOM) + + type 'a folder = + 'a -> int -> [ `Uchar of uchar | `Malformed of string ] -> 'a + + let fold_utf_8 f acc s = + let rec loop acc f s i l = + if i = l then acc else + let need = unsafe_array_get utf_8_len (unsafe_byte s i) in + if need = 0 then loop (f acc i (malformed s i 1)) f s (i + 1) l else + let rem = l - i in + if rem < need then f acc i (malformed s i rem) else + loop (f acc i (r_utf_8 s i need)) f s (i + need) l + in + loop acc f s 0 (String.length s) + + let fold_utf_16be f acc s = + let rec loop acc f s i l = + if i = l then acc else + let rem = l - i in + if rem < 2 then f acc i (malformed s i 1) else + match r_utf_16 s i (i + 1) with + | `Uchar _ | `Malformed _ as v -> loop (f acc i v) f s (i + 2) l + | `Hi hi -> + if rem < 4 then f acc i (malformed s i rem) else + loop (f acc i (r_utf_16_lo hi s (i + 2) (i + 3))) f s (i + 4) l + in + loop acc f s 0 (String.length s) + + let fold_utf_16le f acc s = (* [fold_utf_16be], bytes swapped. *) + let rec loop acc f s i l = + if i = l then acc else + let rem = l - i in + if rem < 2 then f acc i (malformed s i 1) else + match r_utf_16 s (i + 1) i with + | `Uchar _ | `Malformed _ as v -> loop (f acc i v) f s (i + 2) l + | `Hi hi -> + if rem < 4 then f acc i (malformed s i rem) else + loop (f acc i (r_utf_16_lo hi s (i + 3) (i + 2))) f s (i + 4) l + in + loop acc f s 0 (String.length s) +end + +module Buffer = struct + let add_utf_8 b u = + let w byte = Buffer.add_char b (unsafe_chr byte) in (* inlined. *) + if u <= 0x007F then + (w u) + else if u <= 0x07FF then + (w (0xC0 lor (u lsr 6)); + w (0x80 lor (u land 0x3F))) + else if u <= 0xFFFF then + (w (0xE0 lor (u lsr 12)); + w (0x80 lor ((u lsr 6) land 0x3F)); + w (0x80 lor (u land 0x3F))) + else + (w (0xF0 lor (u lsr 18)); + w (0x80 lor ((u lsr 12) land 0x3F)); + w (0x80 lor ((u lsr 6) land 0x3F)); + w (0x80 lor (u land 0x3F))) + + let add_utf_16be b u = + let w byte = Buffer.add_char b (unsafe_chr byte) in (* inlined. *) + if u < 0x10000 then (w (u lsr 8); w (u land 0xFF)) else + let u' = u - 0x10000 in + let hi = (0xD800 lor (u' lsr 10)) in + let lo = (0xDC00 lor (u' land 0x3FF)) in + w (hi lsr 8); w (hi land 0xFF); + w (lo lsr 8); w (lo land 0xFF) + + let add_utf_16le b u = (* swapped add_utf_16be. *) + let w byte = Buffer.add_char b (unsafe_chr byte) in (* inlined. *) + if u < 0x10000 then (w (u land 0xFF); w (u lsr 8)) else + let u' = u - 0x10000 in + let hi = (0xD800 lor (u' lsr 10)) in + let lo = (0xDC00 lor (u' land 0x3FF)) in + w (hi land 0xFF); w (hi lsr 8); + w (lo land 0xFF); w (lo lsr 8) +end + +(*--------------------------------------------------------------------------- + Copyright 2012 Daniel C. Bünzli + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + 3. Neither the name of Daniel C. Bünzli nor the names of + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + ---------------------------------------------------------------------------*) + +end + +module Jsonm = struct + +(*--------------------------------------------------------------------------- + Copyright %%COPYRIGHT%%. All rights reserved. + Distributed under the BSD3 license, see license at the end of the file. + %%NAME%% release %%VERSION%% + ---------------------------------------------------------------------------*) + +(* Braced non-terminals in comments refer to RFC 4627 non-terminals. *) + +let io_buffer_size = 65536 (* IO_BUFFER_SIZE 4.0.0 *) +let pp = Format.fprintf + +(* Unsafe string byte manipulations. If you don't believe the authors's + invariants, replacing with safe versions makes everything safe in the + module. He won't be upset. *) + +let unsafe_blit = String.unsafe_blit +let unsafe_set_byte s j byte = String.unsafe_set s j (Char.unsafe_chr byte) +let unsafe_byte s j = Char.code (String.unsafe_get s j) + +(* Characters and their classes *) + +let ux_eoi = max_int (* End of input, outside unicode range. *) +let ux_soi = max_int - 1 (* Start of input, outside unicode range. *) +let u_nl = 0x0A (* \n *) +let u_sp = 0x20 (* *) +let u_quot = 0x22 (* '' *) +let u_lbrack = 0x5B (* [ *) +let u_rbrack = 0x5D (* ] *) +let u_lbrace = 0x7B (* { *) +let u_rbrace = 0x7D (* } *) +let u_colon = 0x3A (* : *) +let u_dot = 0x2E (* . *) +let u_comma = 0x2C (* , *) +let u_minus = 0x2D (* - *) +let u_slash = 0x2F (* / *) +let u_bslash = 0x5C (* \ *) +let u_times = 0x2A (* * *) + +let must_escape u = u <= 0x1F || u = 0x22 || u = 0x5C +let is_digit u = 0x30 <= u && u <= 0x39 +let is_hex_digit u = + 0x30 <= u && u <= 0x39 || 0x41 <= u && u <= 0x46 || 0x61 <= u && u <= 0x66 + +let is_white = function (* N.B. Uutf normalizes U+000D to U+000A. *) +| 0x20 | 0x09 | 0x0A -> true | _ -> false + +let is_val_sep = function (* N.B. Uutf normalizes U+000D to U+000A. *) +| 0x20 | 0x09 | 0x0A | 0x2C | 0x5D | 0x7D -> true | _ -> false + +(* Data model *) + +type lexeme = [ +| `Null | `Bool of bool | `String of string | `Float of float +| `Name of string | `As | `Ae | `Os | `Oe ] + +let pp_lexeme ppf = function +| `Null -> pp ppf "`Null" +| `Bool b -> pp ppf "@[`Bool %b@]" b +| `String s -> pp ppf "@[`String %S@]" s +| `Name s -> pp ppf "@[`Name %S@]" s +| `Float f -> pp ppf "@[`Float %s@]" (string_of_float f) +| `As -> pp ppf "`As" +| `Ae -> pp ppf "`Ae" +| `Os -> pp ppf "`Os" +| `Oe -> pp ppf "`Oe" + +(* Decode *) + +type error = [ +| `Illegal_BOM +| `Illegal_escape of + [ `Not_hex_uchar of int + | `Not_esc_uchar of int + | `Not_lo_surrogate of int + | `Lone_lo_surrogate of int + | `Lone_hi_surrogate of int ] +| `Illegal_string_uchar of int +| `Illegal_bytes of string +| `Illegal_literal of string +| `Illegal_number of string +| `Unclosed of [ `As | `Os | `String | `Comment ] +| `Expected of + [ `Comment | `Value | `Name | `Name_sep | `Json | `Eoi + | `Aval of bool (* [true] if first array value *) + | `Omem of bool (* [true] if first object member *) ]] + +let err_bom = `Error (`Illegal_BOM) +let err_not_hex u = `Error (`Illegal_escape (`Not_hex_uchar u)) +let err_not_esc u = `Error (`Illegal_escape (`Not_esc_uchar u)) +let err_not_lo p = `Error (`Illegal_escape (`Not_lo_surrogate p)) +let err_lone_lo p = `Error (`Illegal_escape (`Lone_lo_surrogate p)) +let err_lone_hi p = `Error (`Illegal_escape (`Lone_hi_surrogate p)) +let err_str_char u = `Error (`Illegal_string_uchar u) +let err_bytes bs = `Error (`Illegal_bytes bs) +let err_unclosed_comment = `Error (`Unclosed `Comment) +let err_unclosed_string = `Error (`Unclosed `String) +let err_unclosed_arr = `Error (`Unclosed `As) +let err_unclosed_obj = `Error (`Unclosed `Os) +let err_number s = `Error (`Illegal_number s) +let err_literal s = `Error (`Illegal_literal s) +let err_exp_comment = `Error (`Expected `Comment) +let err_exp_value = `Error (`Expected `Value) +let err_exp_name = `Error (`Expected `Name) +let err_exp_nsep = `Error (`Expected `Name_sep) +let err_exp_arr_fst = `Error (`Expected (`Aval true)) +let err_exp_arr_nxt = `Error (`Expected (`Aval false)) +let err_exp_obj_fst = `Error (`Expected (`Omem true)) +let err_exp_obj_nxt = `Error (`Expected (`Omem false)) +let err_exp_json = `Error (`Expected `Json) +let err_exp_eoi = `Error (`Expected `Eoi) + +let pp_uchar ppf u = + if u <= 0x1F (* most control chars *) then Uutf.pp_cp ppf u else + let b = Buffer.create 4 in + Uutf.Buffer.add_utf_8 b u; + pp ppf "'%s' (%a)" (Buffer.contents b) Uutf.pp_cp u + +let pp_error ppf = function +| `Illegal_BOM -> pp ppf "@[illegal@ initial@ BOM@ in@ character@ stream@]" +| `Illegal_escape r -> + pp ppf "@[illegal@ escape,@ "; + begin match r with + | `Not_hex_uchar u -> pp ppf "%a@ not@ a@ hex@ digit@]" pp_uchar u + | `Not_esc_uchar u -> pp ppf "%a@ not@ an@ escaped@ character@]" pp_uchar u + | `Lone_lo_surrogate p -> pp ppf "%a@ lone@ low@ surrogate@]" Uutf.pp_cp p + | `Lone_hi_surrogate p -> pp ppf "%a@ lone@ high@ surrogate@]" Uutf.pp_cp p + | `Not_lo_surrogate p -> pp ppf "%a@ not@ a@ low@ surrogate@]" Uutf.pp_cp p + end +| `Illegal_string_uchar u -> + pp ppf "@[illegal@ character@ in@ JSON@ string@ (%a)@]" pp_uchar u +| `Illegal_bytes bs -> + let l = String.length bs in + pp ppf "@[illegal@ bytes@ in@ character@ stream@ ("; + if l > 0 then pp ppf "%02X" (Char.code (bs.[0])); + for i = 1 to l - 1 do pp ppf " %02X" (Char.code (bs.[i])) done; + pp ppf ")@]" +| `Illegal_number n -> pp ppf "@[illegal@ number@ (%s)@]" n +| `Illegal_literal l -> pp ppf "@[illegal@ literal@ (%s)@]" l +| `Unclosed r -> + pp ppf "@[unclosed@ "; + begin match r with + | `As -> pp ppf "array@]"; + | `Os -> pp ppf "object@]"; + | `String -> pp ppf "string@]"; + | `Comment -> pp ppf "comment@]" + end +| `Expected r -> + pp ppf "@[expected@ "; + begin match r with + | `Comment -> pp ppf "JavaScript@ comment@]" + | `Value -> pp ppf "JSON@ value@]" + | `Name -> pp ppf "member@ name@]" + | `Name_sep -> pp ppf "name@ separator@ (':')@]" + | `Aval true -> pp ppf "value@ or@ array@ end@ (value@ or@ ']')@]" + | `Aval false -> pp ppf "value@ separator@ or@ array@ end@ (','@ or@ ']')@]" + | `Omem true -> pp ppf "member@ name@ or@ object@ end@ ('\"'@ or@ '}')@]" + | `Omem false ->pp ppf "value@ separator@ or@ object@ end@ (','@ or@ '}')@]" + | `Json -> pp ppf "JSON@ text@ ('{'@ or@ '[')@]" + | `Eoi -> pp ppf "end@ of@ input@]" + end + +type pos = int * int +type encoding = [ `UTF_8 | `UTF_16 | `UTF_16BE | `UTF_16LE ] +type src = [ `Channel of in_channel | `String of string | `Manual ] +type decode = [ `Await | `End | `Lexeme of lexeme | `Error of error ] +type uncut = [ `Comment of [ `M | `S ] * string | `White of string ] + +let pp_decode ppf = function +| `Lexeme l -> pp ppf "@[`Lexeme @[(%a)@]@]" pp_lexeme l +| `Await -> pp ppf "`Await" +| `End -> pp ppf "`End" +| `Error e -> pp ppf "@[`Error @[(%a)@]@]" pp_error e +| `White s -> pp ppf "@[`White @[%S@]@]" s +| `Comment (style, s) -> + let pr_style ppf = function `M -> pp ppf "`M" | `S -> pp ppf "`S" in + pp ppf "@[`Comment @[(%a, %S)@]@]" pr_style style s + +type decoder = + { u : Uutf.decoder; (* Unicode character decoder. *) + buf : Buffer.t; (* string accumulation buffer. *) + mutable uncut : bool; (* [true] to bufferize comments and white space. *) + mutable s_line : int; (* last saved start line. *) + mutable s_col : int; (* last saved start column. *) + mutable e_line : int; (* last saved end line. *) + mutable e_col : int; (* last saved end column. *) + mutable c : Uutf.uchar; (* character lookahead. *) + mutable stack : (* stack of open arrays and objects. *) + [ `As of pos | `Os of pos ] list; + mutable next_name : bool; (* [true] if next decode should be [`Name]. *) + mutable last_start : bool; (* [true] if last lexeme was `As or `Os. *) + mutable k : (* decoder continuation. *) + decoder -> [ decode | uncut ] } + +let baddc d c = Uutf.Buffer.add_utf_8 d.buf c +let badd d = Uutf.Buffer.add_utf_8 d.buf d.c +let buf d = let t = Buffer.contents d.buf in (Buffer.clear d.buf; t) +let dpos d = Uutf.decoder_line d.u, Uutf.decoder_col d.u +let spos d = d.s_line <- Uutf.decoder_line d.u; d.s_col <- Uutf.decoder_col d.u +let epos d = d.e_line <- Uutf.decoder_line d.u; d.e_col <- Uutf.decoder_col d.u +let stack_range d = match d.stack with [] -> assert false +| `As (l,c) :: _ | `Os (l,c) :: _ -> d.s_line <- l; d.s_col <- c; epos d + +let dpop d = match (spos d; epos d; d.stack) with +| _ :: (`Os _ :: _ as ss) -> d.next_name <- true; d.stack <- ss +| _ :: (`As _ :: _ as ss) -> d.next_name <- false; d.stack <- ss +| _ :: [] -> d.next_name <- false; d.stack <- [] +| [] -> assert false + +let ret_eoi d = `End +let ret (v : [< decode | uncut]) k d = d.k <- k; v +let rec readc k d = match Uutf.decode d.u with +| `Uchar u -> d.c <- u; k d +| `End -> d.c <- ux_eoi; k d +| `Await -> ret `Await (readc k) d +| `Malformed bs -> d.c <- Uutf.u_rep; epos d; ret (err_bytes bs) k d + +let rec r_scomment k d = (* single line comment. // was eaten. *) + if (d.c <> u_nl && d.c <> ux_eoi) then (badd d; readc (r_scomment k) d) else + (epos d; ret (`Comment (`S, buf d)) (readc k) d) + +let rec r_mcomment closing k d = (* multiline comment. /* was eaten. *) + if (d.c = ux_eoi) then (epos d; ret err_unclosed_comment ret_eoi d) else + if closing then begin + if (d.c = u_slash) then (epos d; ret (`Comment (`M, buf d)) (readc k) d)else + if (d.c = u_times) then (badd d; readc (r_mcomment true k) d) else + (baddc d u_times; badd d; readc (r_mcomment false k) d) + end else begin + if (d.c = u_times) then readc (r_mcomment true k) d else + (badd d; readc (r_mcomment false k) d) + end + +let r_comment k d = (* comment, / was eaten. *) + if d.c = u_slash then readc (r_scomment k) d else + if d.c = u_times then readc (r_mcomment false k) d else + (epos d; ret err_exp_comment k d) + +let rec r_ws_uncut k d = + if (is_white d.c) then (epos d; badd d; readc (r_ws_uncut k) d) else + ret (`White (buf d)) k d + +let rec r_white_uncut k d = (* {ws} / comment *) + if (is_white d.c) then (spos d; r_ws_uncut (r_white_uncut k) d) else + if (d.c = u_slash) then (spos d; readc (r_comment (r_white_uncut k)) d) else + k d + +let rec r_ws k d = if (is_white d.c) then readc (r_ws k) d else k d (* {ws} *) +let r_white k d = if d.uncut then r_white_uncut k d else r_ws k d + +let rec r_u_escape hi u count k d = (* unicode escapes. *) + let error err k d = baddc d Uutf.u_rep; ret err k d in + if count > 0 then + if not (is_hex_digit d.c) then (epos d; error (err_not_hex d.c) (readc k) d) + else + let u = u * 16 + (if d.c <= 0x39 (* 9 *) then d.c - 0x30 else + if d.c <= 0x46 (* F *) then d.c - 0x37 else d.c - 0x57) + in + (epos d; readc (r_u_escape hi u (count - 1) k) d) + else match hi with + | Some hi -> (* combine high and low surrogate into scalar value. *) + if u < 0xDC00 || u > 0xDFFF then error (err_not_lo u) k d else + let u = ((((hi land 0x3FF) lsl 10) lor (u land 0x3FF)) + 0x10000) in + (baddc d u; k d) + | None -> + if u < 0xD800 || u > 0xDFFF then (baddc d u; k d) else + if u > 0xDBFF then error (err_lone_lo u) k d else + if d.c <> u_bslash then error (err_lone_hi u) k d else + readc (fun d -> + if d.c <> 0x75 (* u *) then error (err_lone_hi u) (r_escape k) d else + readc (r_u_escape (Some u) 0 4 k) d) d + +and r_escape k d = match d.c with +| 0x22 (* '' *)-> baddc d u_quot; readc k d +| 0x5C (* \ *) -> baddc d u_bslash; readc k d +| 0x2F (* / *) -> baddc d u_slash; readc k d +| 0x62 (* b *) -> baddc d 0x08; readc k d +| 0x66 (* f *) -> baddc d 0x0C; readc k d +| 0x6E (* n *) -> baddc d u_nl; readc k d +| 0x72 (* r *) -> baddc d 0x0D; readc k d +| 0x74 (* t *) -> baddc d 0x09; readc k d +| 0x75 (* u *) -> readc (r_u_escape None 0 4 k) d +| c -> epos d; baddc d Uutf.u_rep; ret (err_not_esc c) (readc k) d + +let rec r_string k d = (* {string}, '' eaten. *) + if d.c = ux_eoi then (epos d; ret err_unclosed_string ret_eoi d) else + if not (must_escape d.c) then (badd d; readc (r_string k) d) else + if d.c = u_quot then (epos d; readc k d) else + if d.c = u_bslash then readc (r_escape (r_string k)) d else + (epos d; baddc d Uutf.u_rep; ret (err_str_char d.c) (readc (r_string k)) d) + +let rec r_float k d = (* {number} *) + if not (is_val_sep d.c) && d.c <> ux_eoi + then (epos d; badd d; readc (r_float k) d) else + let s = buf d in + try ret (`Lexeme (`Float (float_of_string s))) k d with + | Failure _ -> ret (err_number s) k d + +let rec r_literal k d = (* {true} / {false} / {null} *) + if not (is_val_sep d.c) && d.c <> ux_eoi + then (epos d; badd d; readc (r_literal k) d) else + match buf d with + | "true" -> ret (`Lexeme (`Bool true)) k d + | "false" -> ret (`Lexeme (`Bool false)) k d + | "null" -> ret (`Lexeme `Null) k d + | s -> ret (err_literal s) k d + +let rec r_value err k d = match d.c with (* {value} *) +| 0x5B (* [ *) -> (* {begin-array} *) + spos d; epos d; d.last_start <- true; + d.stack <- `As (dpos d) :: d.stack; + ret (`Lexeme `As) (readc k) d +| 0x7B (* { *) -> (* {begin-object} *) + spos d; epos d; d.last_start <- true; d.next_name <- true; + d.stack <- `Os (dpos d) :: d.stack; + ret (`Lexeme `Os) (readc k) d +| 0x22 (* '' *) -> + let lstring k d = ret (`Lexeme (`String (buf d))) k d in + spos d; readc (r_string (lstring k)) d +| 0x66 (* f *) | 0x6E (* n *) | 0x74 (* t *) -> + spos d; r_literal k d +| u when is_digit u || u = u_minus -> spos d; r_float k d +| u -> err k d + +let rec discard_to c1 c2 err k d = + if d.c = c1 || d.c = c2 || d.c = ux_eoi then ret err k d else + (epos d; readc (discard_to c1 c2 err k) d) + +let r_arr_val k d = (* [{value-separator}] {value} / {end-array} *) + let nxval err k d = spos d; discard_to u_comma u_rbrack err k d in + let last_start = d.last_start in + d.last_start <- false; + if d.c = ux_eoi then (stack_range d; ret err_unclosed_arr ret_eoi d) else + if d.c = u_rbrack then (dpop d; ret (`Lexeme `Ae) (readc k) d) else + if last_start then r_value (nxval err_exp_arr_fst) k d else + if d.c = u_comma then readc (r_white (r_value (nxval err_exp_value) k)) d + else nxval err_exp_arr_nxt k d + +let nxmem err k d = + spos d; d.next_name <- true; discard_to u_comma u_rbrace err k d + +let r_obj_value k d = (* {name-separator} {value} *) + d.next_name <- true; + if d.c = u_colon then readc (r_white (r_value (nxmem err_exp_value) k)) d + else nxmem err_exp_nsep k d + +let r_obj_name k d = (* [{value-separator}] string / end-object *) + let r_name err k d = + let ln k d = ret (`Lexeme (`Name (buf d))) k d in + if d.c <> u_quot then nxmem err k d else (spos d; readc (r_string (ln k)) d) + in + let last_start = d.last_start in + d.last_start <- false; d.next_name <- false; + if d.c = ux_eoi then (stack_range d; ret err_unclosed_obj ret_eoi d) else + if d.c = u_rbrace then (dpop d; ret (`Lexeme `Oe) (readc k) d) else + if last_start then r_name err_exp_obj_fst k d else + if d.c = u_comma then readc (r_white (r_name err_exp_name k)) d else + nxmem err_exp_obj_nxt k d + +let r_end k d = (* end of input *) + if d.c = ux_eoi then ret `End ret_eoi d else + let drain k d = spos d; discard_to ux_eoi ux_eoi err_exp_eoi k d in + drain ret_eoi d + +let rec r_lexeme d = match d.stack with +| `As _ :: _ -> r_white (r_arr_val r_lexeme) d +| `Os _ :: _ -> + if d.next_name then r_white (r_obj_name r_lexeme) d else + r_white (r_obj_value r_lexeme) d +| [] -> r_white (r_end r_lexeme) d + +let rec r_json k d = (* {begin-array} / {begin-object} *) + let err k d = spos d; discard_to u_lbrack u_lbrace err_exp_json (r_json k)d in + if d.c = u_lbrack || d.c = u_lbrace then r_value err k d else err k d + +let r_start d = (* start of input *) + let bom k d = if Uutf.decoder_removed_bom d.u then ret err_bom k d else k d in + readc (bom (r_white (r_json r_lexeme))) d + +let decoder ?encoding src = + let u = Uutf.decoder ?encoding ~nln:(`ASCII 0x000A) src in + { u; buf = Buffer.create 1024; uncut = false; + s_line = 1; s_col = 0; e_line = 1; e_col = 0; + c = ux_soi; next_name = false; last_start = false; stack = []; + k = r_start } + +let decode_uncut d = d.uncut <- true; d.k d +let rec decode d = match (d.uncut <- false; d.k d) with +| #decode as v -> (v :> [> decode]) +| `Comment _ | `White _ -> assert false + +let decoder_src d = Uutf.decoder_src d.u +let decoded_range d = (d.s_line, d.s_col), (d.e_line, d.e_col) +let decoder_encoding d = match Uutf.decoder_encoding d.u with +| #encoding as enc -> enc +| `US_ASCII | `ISO_8859_1 -> assert false + +(* Encode *) + +let invalid_arg fmt = + let b = Buffer.create 20 in (* for thread safety. *) + let ppf = Format.formatter_of_buffer b in + let k ppf = Format.pp_print_flush ppf (); invalid_arg (Buffer.contents b) in + Format.kfprintf k ppf fmt + +let invalid_bounds j l = invalid_arg "invalid bounds (index %d, length %d)" j l +let expect e v = invalid_arg "%a encoded but expected %s" pp_decode v e +let expect_await v = expect "`Await" v +let expect_end l = expect "`End" (`Lexeme l) +let expect_mem_value l = expect "any `Lexeme but `Name, `Oe or `Ae" (`Lexeme l) +let expect_arr_value_ae l = expect "any `Lexeme but `Name or `Oe" (`Lexeme l) +let expect_name_or_oe l = expect "`Lexeme (`Name _ | `Oe)" (`Lexeme l) +let expect_json v = expect "`Lexeme (`As | `Os)" v +let expect_lend lstart v = + expect (if lstart = `As then "`Lexeme `Ae" else "`Lexeme `Oe") v + +type dst = [ `Channel of out_channel | `Buffer of Buffer.t | `Manual ] +type encode = [ `Await | `End | `Lexeme of lexeme ] +type encoder = + { dst : dst; (* output destination. *) + minify : bool; (* [true] for compact output. *) + mutable o : string; (* current output chunk. *) + mutable o_pos : int; (* next output position to write. *) + mutable o_max : int; (* maximal output position to write. *) + buf : Buffer.t; (* buffer to format floats. *) + mutable stack : [`As | `Os ] list; (* stack of open arrays and objects. *) + mutable nest : int; (* nesting level (String.length stack). *) + mutable next_name : bool; (* [true] if next encode should `Name. *) + mutable last_start : bool; (* [true] if last encode was [`As | `Os]. *) + mutable k : (* decoder continuation. *) + encoder -> [ encode | uncut ] -> [ `Ok | `Partial ] } + +let o_rem e = e.o_max - e.o_pos + 1 (* remaining bytes to write in [e.o]. *) +let dst e s j l = (* set [e.o] with [s]. *) + if (j < 0 || l < 0 || j + l > String.length s) then invalid_bounds j l; + e.o <- s; e.o_pos <- j; e.o_max <- j + l - 1 + +let partial k e = function `Await -> k e | v -> expect_await v +let flush k e = match e.dst with (* get free space in [d.o] and [k]ontinue. *) +| `Manual -> e.k <- partial k; `Partial +| `Buffer b -> Buffer.add_substring b e.o 0 e.o_pos; e.o_pos <- 0; k e +| `Channel oc -> output oc e.o 0 e.o_pos; e.o_pos <- 0; k e + +let rec writeb b k e = (* write byte [b] and [k]ontinue. *) + if e.o_pos > e.o_max then flush (writeb b k) e else + (unsafe_set_byte e.o e.o_pos b; e.o_pos <- e.o_pos + 1; k e) + +let rec writes s j l k e = (* write [l] bytes from [s] starting at [j]. *) + let rem = o_rem e in + if rem >= l then (unsafe_blit s j e.o e.o_pos l; e.o_pos <- e.o_pos + l; k e) + else begin + unsafe_blit s j e.o e.o_pos rem; e.o_pos <- e.o_pos + rem; + flush (writes s (j + rem) (l - rem) k) e + end + +let rec writebuf j l k e = (* write [l] bytes from [e.buf] starting at [j]. *) + let rem = o_rem e in + if rem >= l + then (Buffer.blit e.buf j e.o e.o_pos l; e.o_pos <- e.o_pos + l; k e) + else begin + Buffer.blit e.buf j e.o e.o_pos rem; e.o_pos <- e.o_pos + rem; + flush (writebuf (j + rem) (l - rem) k) e + end + +let w_indent k e = + let rec loop indent k e = + let spaces e indent = + let max = e.o_pos + indent - 1 in + for j = e.o_pos to max do unsafe_set_byte e.o j u_sp done; + e.o_pos <- max + 1 + in + let rem = o_rem e in + if rem < indent then (spaces e rem; flush (loop (indent - rem) k) e) else + (spaces e indent; k e) + in + loop (e.nest * 2) k e + +let rec w_json_string s k e = (* escapes as mandated by the standard. *) + let rec loop s j pos max k e = + if pos > max then (if j > max then k e else writes s j (pos - j) k e) else + let next = pos + 1 in + let escape esc = (* assert (String.length esc = 2 ). *) + writes s j (pos - j) (writes esc 0 2 (loop s next next max k)) e + in + match unsafe_byte s pos with + | 0x22 -> escape "\\\"" + | 0x5C -> escape "\\\\" + | 0x0A -> escape "\\n" + | c when c <= 0x1F -> + let hex d = (if d < 10 then 0x30 + d else 0x41 + (d - 10)) in + writes s j (pos - j) + (writes "\\u00" 0 4 + (writeb (hex (c lsr 4)) + (writeb (hex (c land 0xF)) + (loop s next next max k)))) e + | c -> loop s j next max k e + in + writeb u_quot (loop s 0 0 (String.length s - 1) (writeb u_quot k)) e + +let w_name n k e = + e.last_start <- false; e.next_name <- false; + w_json_string n (writeb u_colon k) e + +let w_value ~in_obj l k e = match l with +| `String s -> + e.last_start <- false; e.next_name <- in_obj; + w_json_string s k e +| `Bool b -> + e.last_start <- false; e.next_name <- in_obj; + if b then writes "true" 0 4 k e else writes "false" 0 5 k e +| `Float f -> + e.last_start <- false; e.next_name <- in_obj; + Buffer.clear e.buf; Printf.bprintf e.buf "%.16g" f; + writebuf 0 (Buffer.length e.buf) k e +| `Os -> + e.last_start <- true; e.next_name <- true; + e.nest <- e.nest + 1; e.stack <- `Os :: e.stack; + writeb u_lbrace k e +| `As -> + e.last_start <- true; e.next_name <- false; + e.nest <- e.nest + 1; e.stack <- `As :: e.stack; + writeb u_lbrack k e +| `Null -> + e.last_start <- false; e.next_name <- in_obj; + writes "null" 0 4 k e +| `Oe | `Ae | `Name _ as l -> + if in_obj then expect_mem_value l else expect_arr_value_ae l + +let w_lexeme k e l = + let epop e = + e.last_start <- false; + e.nest <- e.nest - 1; e.stack <- List.tl e.stack; + match e.stack with + | `Os :: _ -> e.next_name <- true; + | _ -> e.next_name <- false + in + match List.hd e.stack with + | `Os -> (* inside object. *) + if not e.next_name then w_value ~in_obj:true l k e else + begin match l with + | `Name n -> + let name n k e = + if e.minify then w_name n k e else + writeb u_nl (w_indent (w_name n (writeb u_sp k))) e + in + if e.last_start then name n k e else + writeb u_comma (name n k) e + | `Oe -> + if e.minify || e.last_start then (epop e; writeb u_rbrace k e) else + (epop e; writeb u_nl (w_indent (writeb u_rbrace k)) e) + | v -> expect_name_or_oe l + end + | `As -> (* inside array. *) + begin match l with + | `Ae -> + if e.minify || e.last_start then (epop e; writeb u_rbrack k e) else + (epop e; writeb u_nl (w_indent (writeb u_rbrack k)) e) + | l -> + let value l k e = + if e.minify then w_value ~in_obj:false l k e else + writeb u_nl (w_indent (w_value ~in_obj:false l k)) e + in + if e.last_start then value l k e else + writeb u_comma (value l k) e + end + +let rec encode_ k e = function +| `Lexeme l -> + if e.stack = [] then expect_end l else w_lexeme k e l +| `End as v -> + if e.stack = [] then flush k e else expect_lend (List.hd e.stack) v +| `White w -> + writes w 0 (String.length w) k e +| `Comment (`S, c) -> + writes "//" 0 2 (writes c 0 (String.length c) (writeb u_nl k)) e +| `Comment (`M, c) -> + writes "/*" 0 2 (writes c 0 (String.length c) (writes "*/" 0 2 k)) e +| `Await -> `Ok + +let rec encode_loop e = e.k <- encode_ encode_loop; `Ok +let rec encode_json e = function (* first [k] to start with [`Os] or [`As]. *) +| `Lexeme (`Os | `As as l) -> w_value true (* irrelevant *) l encode_loop e +| `End | `Lexeme _ as v -> expect_json v +| `White _ | `Comment _ as v -> encode_ (fun e -> e.k <- encode_json; `Ok) e v +| `Await -> `Ok + +let encoder ?(minify = true) dst = + let o, o_pos, o_max = match dst with + | `Manual -> "", 1, 0 (* implies [o_rem e = 0]. *) + | `Buffer _ + | `Channel _ -> String.create io_buffer_size, 0, io_buffer_size - 1 + in + { dst = (dst :> dst); minify; o; o_pos; o_max; buf = Buffer.create 30; + stack = []; nest = 0; next_name = false; last_start = false; + k = encode_json } + +let encode e v = e.k e (v :> [ encode | uncut ]) +let encoder_dst e = e.dst +let encoder_minify e = e.minify + +(* Manual *) + +module Manual = struct + let src d = Uutf.Manual.src d.u + let dst = dst + let dst_rem = o_rem +end + +(* Uncut *) + +module Uncut = struct + let decode = decode_uncut + let pp_decode = pp_decode + let encode e v = e.k e (v :> [ encode | uncut]) +end + +(*--------------------------------------------------------------------------- + Copyright %%COPYRIGHT%% + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + 3. Neither the name of Daniel C. Bünzli nor the names of + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR + A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT + OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, + SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT + LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE + OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + ---------------------------------------------------------------------------*) + +end + + +(* From http://erratique.ch/software/jsonm/doc/Jsonm.html#datamodel *) +type t = + [ `Null + | `Bool of bool + | `Float of float + | `String of string + | `A of t list + | `O of (string * t) list ] + +exception Escape of ((int * int) * (int * int)) * Jsonm.error + +let json_of_src src = + let d = Jsonm.decoder src in + let dec () = match Jsonm.decode d with + | `Lexeme l -> l + | `Error e -> raise (Escape (Jsonm.decoded_range d, e)) + | `End + | `Await -> assert false + in + let rec value v k = match v with + | `Os -> obj [] k + | `As -> arr [] k + | `Null + | `Bool _ + | `String _ + | `Float _ as v -> k v + | _ -> assert false + and arr vs k = match dec () with + | `Ae -> k (`A (List.rev vs)) + | v -> value v (fun v -> arr (v :: vs) k) + and obj ms k = match dec () with + | `Oe -> k (`O (List.rev ms)) + | `Name n -> value (dec ()) (fun v -> obj ((n, v) :: ms) k) + | _ -> assert false + in + try `JSON (value (dec ()) (fun v -> v)) + with Escape (r, e) -> `Error (r, e) + +let json_to_dst ~minify dst (json:t) = + let enc e l = ignore (Jsonm.encode e (`Lexeme l)) in + let rec value v k e = match v with + | `A vs -> arr vs k e + | `O ms -> obj ms k e + | `Null | `Bool _ | `Float _ | `String _ as v -> enc e v; k e + and arr vs k e = enc e `As; arr_vs vs k e + and arr_vs vs k e = match vs with + | v :: vs' -> value v (arr_vs vs' k) e + | [] -> enc e `Ae; k e + and obj ms k e = enc e `Os; obj_ms ms k e + and obj_ms ms k e = match ms with + | (n, v) :: ms -> enc e (`Name n); value v (obj_ms ms k) e + | [] -> enc e `Oe; k e + in + let e = Jsonm.encoder ~minify dst in + let finish e = ignore (Jsonm.encode e `End) in + match json with + | `A _ | `O _ as json -> value json finish e + | _ -> invalid_arg "invalid json text" + +let to_buffer buf (json:t) = + json_to_dst ~minify:true (`Buffer buf) json + +let output t = + let buf = Buffer.create 1024 in + to_buffer buf t; + Buffer.contents buf + +let parse_error fmt = + Printf.kprintf (fun msg -> + Printf.eprintf "parse error: %s\n" msg; + exit 1 + ) fmt + +let string_of_error error = + Jsonm.pp_error Format.str_formatter error; + Format.flush_str_formatter () + +let of_buffer buf: t = + let str = Buffer.contents buf in + match json_of_src (`String str) with + | `JSON j -> j + | `Error (_,e) -> parse_error "JSON.of_buffer %s" (string_of_error e) + +let of_channel ic = + match json_of_src (`Channel ic) with + | `JSON j -> j + | `Error (_,e) -> parse_error "JSON.of_buffer %s" (string_of_error e) + +let input str: t = + match json_of_src (`String str) with + | `JSON j -> j + | `Error (_,e) -> + Jsonm.pp_error Format.str_formatter e; + parse_error "JSON.input %s" (string_of_error e) + +(* string *) +let of_string s = `String s + +let to_string = function + | `String s -> s + | j -> parse_error "JSON.to_string: %s" (output j) + +type code = { + code : int; + constr: string; + descr : string; + doc : string; +} + +type section = { + section: string; + codes : code list; +} + +let normalize s = + String.iteri (fun i -> function + | 'A'..'Z' as c -> if i > 1 then s.[i] <- Char.lowercase c + | ' '|'-'|'\'' -> s.[i] <- '_' + | _ -> () + ) s + +let read ic = + let json = of_channel ic in + match json with + | `O o -> + let section = + match List.assoc "class" o with + | `O o -> + let s = String.uncapitalize (to_string (List.assoc "title" o)) in + normalize s; + s + | _ -> assert false in + + let codes = + match List.assoc "codes" o with + | `O o -> + List.fold_left (fun codes (code, o) -> + let code = int_of_string code in + if code = 122 then + (* Same as 414 but for IE7 ??? *) + codes + else ( + let o = match o with + | `O o -> o + | _ -> assert false in + let descr = to_string (List.assoc "title" o) in + let constr = "`" ^ ( + try + let i = String.index descr '(' in + String.sub descr 0 (i-1) + with Not_found -> + String.copy descr + ) in + normalize constr; + (* XXX: dirty hack *) + let constr = if constr = "`Ok" then "`OK" else constr in + let doc = to_string (List.assoc "summary" o) in + { constr; descr; code; doc } :: codes + ) + ) [] o + | _ -> assert false + in + { section; codes = List.rev codes } + | _ -> assert false + +let append oc fmt = + Printf.fprintf oc (fmt^^"\n") + +let output_type oc ~mli t = + append oc "type %s_status =" t.section; + List.iteri (fun i c -> + let doc = + if mli then Printf.sprintf " (** %s *)" c.doc + else "" in + if i = 0 then + append oc " [ %s%s" c.constr doc + else + append oc " | %s%s" c.constr doc + ) t.codes; + append oc " ]"; + if mli then + append oc "(** %s *)" (String.capitalize t.section); + append oc "" + +let output_status_types oc ~mli t = + List.iter (output_type oc ~mli) t; + append oc "type status ="; + List.iteri (fun i t -> + if i = 0 then + append oc " [ %s_status" t.section + else + append oc " | %s_status" t.section + ) t; + append oc " ]"; + append oc ""; + append oc "type status_code = [`Code of int | status ]"; + append oc "" + +let iter fn s = + List.iter (fun s -> + List.iter fn s.codes + ) s + +let output_status_of_code oc ~mli s = + if mli then ( + append oc "val status_of_code: int -> status_code"; + append oc "(** Generate status values from int codes. *)" + ) else ( + append oc "let status_of_code: int -> status_code = function"; + iter (fun c -> + append oc " | %d -> %s" c.code c.constr + ) s; + append oc " | cod -> `Code cod"; + ); + append oc "" + +let output_code_of_status oc ~mli s = + if mli then ( + append oc "val code_of_status: status_code -> int"; + append oc "(** Generate an int code from a status value. *)"; + ) else ( + append oc "let code_of_status: status_code -> int = function"; + iter (fun c -> + append oc " | %s -> %d" c.constr c.code + ) s; + append oc " | `Code cod -> cod"; + ); + append oc "" + +let output_string_of_status oc ~mli s = + if mli then ( + append oc "val string_of_status: status_code -> string"; + append oc "(** Give a description of the given status value. *)"; + ) else ( + append oc "let string_of_status: status_code -> string = function"; + iter (fun c -> + append oc " | %s -> \"%d %s\"" c.constr c.code c.descr + ) s; + append oc " | `Code cod -> string_of_int cod"; + ); + append oc "" + +let output_reason_phrase_of_code oc ~mli s = + if mli then ( + append oc "val reason_phrase_of_code: int -> string"; + append oc "(** Give a description of the given int code. *)"; + ) else ( + append oc "let reason_phrase_of_code: int -> string = function"; + iter (fun c -> + append oc " | %d -> %S" c.code c.descr + ) s; + append oc " | cod -> string_of_int cod"; + ); + append oc "" + +let output_is_code oc ~mli t = + List.iter (fun t -> + if mli then ( + append oc "val is_%s: int -> bool" t.section; + append oc "(** Is the given int code belong to the class of %S return code ? *)" t.section; + ) else ( + append oc "let is_%s code =" t.section; + append oc " match status_of_code code with"; + append oc " | #%s_status -> true" t.section; + append oc " | _ -> false"; + ); + append oc "" + ) t; + append oc ""; + if mli then ( + append oc "val is_error: int -> bool"; + append oc "(** Return true for client and server error status codes. *)"; + ) else + append oc "let is_error code = is_client_error code || is_server_error code"; + append oc "" + +type gen = { + constr: string; + string: string; +} + +let g constr string = { constr; string } + +let output_gen_types oc ~mli (name, typ, gens) = + append oc "type %s = [ %s ]" typ + (String.concat " | " (List.map (fun g -> g.constr) gens)); + append oc "" + +let output_gen_convert oc ~mli (name, typ, gens) = + if mli then ( + append oc "val string_of_%s: %s -> string" name typ; + append oc "(** Convert a %s to a string. *)" name; + append oc ""; + append oc "val %s_of_string: string -> %s option" name typ; + append oc "(** Convert a string to a %s. Return [None] if the conversion fails. *)" name; + append oc ""; + ) else ( + append oc "let string_of_%s: %s -> string = function" name typ; + List.iter (fun g -> + append oc " | %s -> %S" g.constr g.string + ) gens; + append oc ""; + append oc "let %s_of_string: string -> %s option = function" name typ; + List.iter (fun g -> + append oc " | %S -> Some %s" g.string g.constr + ) gens; + append oc " | _ -> None"; + ); + append oc "" + +let t = + List.map (fun f -> read (open_in f)) [ + "codes/1.json"; + "codes/2.json"; + "codes/3.json"; + "codes/4.json"; + "codes/5.json"; + ] + +let version = ("version" , "version", [ + g "`HTTP_1_0" "HTTP/1.0"; + g "`HTTP_1_1" "HTTP/1.1"; + ]) + +let meth = ("method" , "meth", [ + g "`GET" "GET"; + g "`POST" "POST"; + g "`HEAD" "HEAD"; + g "`DELETE" "DELETE"; + g "`PATCH" "PATCH"; + g "`PUT" "PUT"; + g "`OPTIONS" "OPTIONS"; + ]) + +let gen oc ~mli = + append oc "(* Auto-Generated by 'ocaml generate.ml' *)"; + append oc ""; + output_gen_types oc ~mli version; + output_gen_types oc ~mli meth; + output_status_types oc ~mli t; + output_gen_convert oc ~mli version; + output_gen_convert oc ~mli meth; + output_status_of_code oc ~mli t; + output_code_of_status oc ~mli t; + output_string_of_status oc ~mli t; + output_reason_phrase_of_code oc ~mli t; + output_is_code oc ~mli t + +let () = + let ml = open_out "code.ml" in + let mli = open_out "code.mli" in + gen ml ~mli:false; + gen mli ~mli:true; + close_out ml; + close_out mli diff --git a/setup.ml b/setup.ml index 879f855881..af3f7a9a60 100644 --- a/setup.ml +++ b/setup.ml @@ -1,46 +1,55 @@ (* setup.ml generated for the first time by OASIS v0.3.0 *) (* OASIS_START *) -(* DO NOT EDIT (digest: b3a14ff2b81fbc75601cb4dc95d36931) *) +(* DO NOT EDIT (digest: fec775f955fd78de0170727ff96be945) *) (* - Regenerated by OASIS v0.3.0 + Regenerated by OASIS v0.4.0 Visit http://oasis.forge.ocamlcore.org for more information and documentation about functions used in this file. *) module OASISGettext = struct -(* # 21 "src/oasis/OASISGettext.ml" *) +(* # 22 "src/oasis/OASISGettext.ml" *) + let ns_ str = str + let s_ str = str - let f_ (str : ('a, 'b, 'c, 'd) format4) = + + let f_ (str: ('a, 'b, 'c, 'd) format4) = str + let fn_ fmt1 fmt2 n = if n = 1 then fmt1^^"" else fmt2^^"" + let init = [] + end module OASISContext = struct -(* # 21 "src/oasis/OASISContext.ml" *) +(* # 22 "src/oasis/OASISContext.ml" *) + open OASISGettext + type level = [ `Debug | `Info | `Warning | `Error] + type t = { quiet: bool; @@ -51,6 +60,7 @@ module OASISContext = struct printf: level -> string -> unit; } + let printf lvl str = let beg = match lvl with @@ -61,6 +71,7 @@ module OASISContext = struct in prerr_endline (beg^str) + let default = ref { @@ -72,6 +83,7 @@ module OASISContext = struct printf = printf; } + let quiet = {!default with quiet = true} @@ -92,17 +104,17 @@ module OASISContext = struct end module OASISString = struct -(* # 1 "src/oasis/OASISString.ml" *) - +(* # 22 "src/oasis/OASISString.ml" *) (** Various string utilities. - + Mostly inspired by extlib and batteries ExtString and BatString libraries. @author Sylvain Le Gall *) + let nsplitf str f = if str = "" then [] @@ -123,16 +135,18 @@ module OASISString = struct push (); List.rev !lst + (** [nsplit c s] Split the string [s] at char [c]. It doesn't include the separator. *) let nsplit str c = nsplitf str ((=) c) + let find ~what ?(offset=0) str = let what_idx = ref 0 in - let str_idx = ref offset in - while !str_idx < String.length str && + let str_idx = ref offset in + while !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx @@ -142,16 +156,18 @@ module OASISString = struct done; if !what_idx <> String.length what then raise Not_found - else + else !str_idx - !what_idx - let sub_start str len = + + let sub_start str len = let str_len = String.length str in if len >= str_len then "" else String.sub str len (str_len - len) + let sub_end ?(offset=0) str len = let str_len = String.length str in if len >= str_len then @@ -159,12 +175,13 @@ module OASISString = struct else String.sub str 0 (str_len - len) + let starts_with ~what ?(offset=0) str = let what_idx = ref 0 in let str_idx = ref offset in let ok = ref true in while !ok && - !str_idx < String.length str && + !str_idx < String.length str && !what_idx < String.length what do if str.[!str_idx] = what.[!what_idx] then incr what_idx @@ -174,21 +191,23 @@ module OASISString = struct done; if !what_idx = String.length what then true - else + else false + let strip_starts_with ~what str = if starts_with ~what str then sub_start str (String.length what) else raise Not_found + let ends_with ~what ?(offset=0) str = let what_idx = ref ((String.length what) - 1) in let str_idx = ref ((String.length str) - 1) in let ok = ref true in while !ok && - offset <= !str_idx && + offset <= !str_idx && 0 <= !what_idx do if str.[!str_idx] = what.[!what_idx] then decr what_idx @@ -198,15 +217,17 @@ module OASISString = struct done; if !what_idx = -1 then true - else + else false + let strip_ends_with ~what str = if ends_with ~what str then sub_end str (String.length what) else raise Not_found + let replace_chars f s = let buf = String.make (String.length s) 'X' in for i = 0 to String.length s - 1 do @@ -214,29 +235,36 @@ module OASISString = struct done; buf + end module OASISUtils = struct -(* # 21 "src/oasis/OASISUtils.ml" *) +(* # 22 "src/oasis/OASISUtils.ml" *) + open OASISGettext + module MapString = Map.Make(String) + let map_string_of_assoc assoc = List.fold_left (fun acc (k, v) -> MapString.add k v acc) MapString.empty assoc + module SetString = Set.Make(String) + let set_string_add_list st lst = List.fold_left (fun acc e -> SetString.add e acc) st lst + let set_string_of_list = set_string_add_list SetString.empty @@ -245,6 +273,7 @@ module OASISUtils = struct let compare_csl s1 s2 = String.compare (String.lowercase s1) (String.lowercase s2) + module HashStringCsl = Hashtbl.Make (struct @@ -257,6 +286,7 @@ module OASISUtils = struct Hashtbl.hash (String.lowercase s) end) + let varname_of_string ?(hyphen='_') s = if String.length s = 0 then begin @@ -287,6 +317,7 @@ module OASISUtils = struct String.lowercase buf end + let varname_concat ?(hyphen='_') p s = let what = String.make 1 hyphen in let p = @@ -307,42 +338,49 @@ module OASISUtils = struct let is_varname str = str = varname_of_string str + let failwithf fmt = Printf.ksprintf failwith fmt + end module PropList = struct -(* # 21 "src/oasis/PropList.ml" *) +(* # 22 "src/oasis/PropList.ml" *) + open OASISGettext + type name = string + exception Not_set of name * string option exception No_printer of name exception Unknown_field of name * name + let () = Printexc.register_printer (function | Not_set (nm, Some rsn) -> - Some + Some (Printf.sprintf (f_ "Field '%s' is not set: %s") nm rsn) | Not_set (nm, None) -> - Some + Some (Printf.sprintf (f_ "Field '%s' is not set") nm) | No_printer nm -> Some (Printf.sprintf (f_ "No default printer for value %s") nm) | Unknown_field (nm, schm) -> - Some - (Printf.sprintf (f_ "Field %s is not defined in schema %s") nm schm) + Some + (Printf.sprintf + (f_ "Field %s is not defined in schema %s") nm schm) | _ -> None) + module Data = struct - type t = (name, unit -> unit) Hashtbl.t @@ -352,12 +390,13 @@ module PropList = struct let clear t = Hashtbl.clear t -(* # 71 "src/oasis/PropList.ml" *) + +(* # 78 "src/oasis/PropList.ml" *) end + module Schema = struct - type ('ctxt, 'extra) value = { get: Data.t -> string; @@ -445,9 +484,9 @@ module PropList = struct t.name end + module Field = struct - type ('ctxt, 'value, 'extra) t = { set: Data.t -> ?context:'ctxt -> 'value -> unit; @@ -577,28 +616,27 @@ module PropList = struct let fgets data t = t.gets data - end + module FieldRO = struct - let create ?schema ?name ?parse ?print ?default ?update ?help extra = let fld = Field.create ?schema ?name ?parse ?print ?default ?update ?help extra in fun data -> Field.fget data fld - end end module OASISMessage = struct -(* # 21 "src/oasis/OASISMessage.ml" *) +(* # 22 "src/oasis/OASISMessage.ml" *) open OASISGettext open OASISContext + let generic_message ~ctxt lvl fmt = let cond = if ctxt.quiet then @@ -617,31 +655,40 @@ module OASISMessage = struct end) fmt + let debug ~ctxt fmt = generic_message ~ctxt `Debug fmt + let info ~ctxt fmt = generic_message ~ctxt `Info fmt + let warning ~ctxt fmt = generic_message ~ctxt `Warning fmt + let error ~ctxt fmt = generic_message ~ctxt `Error fmt end module OASISVersion = struct -(* # 21 "src/oasis/OASISVersion.ml" *) +(* # 22 "src/oasis/OASISVersion.ml" *) + open OASISGettext + + type s = string + type t = string + type comparator = | VGreater of t | VGreaterEqual of t @@ -652,18 +699,22 @@ module OASISVersion = struct | VAnd of comparator * comparator + (* Range of allowed characters *) let is_digit c = '0' <= c && c <= '9' + let is_alpha c = ('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') + let is_special = function | '.' | '+' | '-' | '~' -> true | _ -> false + let rec version_compare v1 v2 = if v1 <> "" || v2 <> "" then begin @@ -707,11 +758,11 @@ module OASISVersion = struct while !p < String.length v && is_digit v.[!p] do incr p done; - let substr = + let substr = String.sub v !p ((String.length v) - !p) - in - let res = - match String.sub v start_p (!p - start_p) with + in + let res = + match String.sub v start_p (!p - start_p) with | "" -> 0 | s -> int_of_string s in @@ -747,8 +798,14 @@ module OASISVersion = struct let version_of_string str = str + let string_of_version t = t + + let version_compare_string s1 s2 = + version_compare (version_of_string s1) (version_of_string s2) + + let chop t = try let pos = @@ -758,6 +815,7 @@ module OASISVersion = struct with Not_found -> t + let rec comparator_apply v op = match op with | VGreater cv -> @@ -775,6 +833,7 @@ module OASISVersion = struct | VAnd (op1, op2) -> (comparator_apply v op1) && (comparator_apply v op2) + let rec string_of_comparator = function | VGreater v -> "> "^(string_of_version v) @@ -787,6 +846,7 @@ module OASISVersion = struct | VAnd (c1, c2) -> (string_of_comparator c1)^" && "^(string_of_comparator c2) + let rec varname_of_comparator = let concat p v = OASISUtils.varname_concat @@ -805,13 +865,24 @@ module OASISVersion = struct | VAnd (c1, c2) -> (varname_of_comparator c1)^"_and_"^(varname_of_comparator c2) - let version_0_3_or_after t = - comparator_apply t (VGreaterEqual (string_of_version "0.3")) + + let rec comparator_ge v' = + let cmp v = version_compare v v' >= 0 in + function + | VEqual v + | VGreaterEqual v + | VGreater v -> cmp v + | VLesserEqual _ + | VLesser _ -> false + | VOr (c1, c2) -> comparator_ge v' c1 || comparator_ge v' c2 + | VAnd (c1, c2) -> comparator_ge v' c1 && comparator_ge v' c2 + end module OASISLicense = struct -(* # 21 "src/oasis/OASISLicense.ml" *) +(* # 22 "src/oasis/OASISLicense.ml" *) + (** License for _oasis fields @author Sylvain Le Gall @@ -819,16 +890,21 @@ module OASISLicense = struct + + type license = string + type license_exception = string + type license_version = | Version of OASISVersion.t | VersionOrLater of OASISVersion.t | NoVersion + type license_dep_5_unit = { license: license; @@ -837,30 +913,38 @@ module OASISLicense = struct } + type license_dep_5 = | DEP5Unit of license_dep_5_unit | DEP5Or of license_dep_5 list | DEP5And of license_dep_5 list + type t = | DEP5License of license_dep_5 | OtherLicense of string (* URL *) + end module OASISExpr = struct -(* # 21 "src/oasis/OASISExpr.ml" *) +(* # 22 "src/oasis/OASISExpr.ml" *) + + open OASISGettext + type test = string + type flag = string + type t = | EBool of bool | ENot of t @@ -870,8 +954,10 @@ module OASISExpr = struct | ETest of test * string + type 'a choices = (t * 'a) list + let eval var_get t = let rec eval' = function @@ -902,6 +988,7 @@ module OASISExpr = struct in eval' t + let choose ?printer ?name var_get lst = let rec choose_aux = function @@ -938,10 +1025,12 @@ module OASISExpr = struct in choose_aux (List.rev lst) + end module OASISTypes = struct -(* # 21 "src/oasis/OASISTypes.ml" *) +(* # 22 "src/oasis/OASISTypes.ml" *) + @@ -958,25 +1047,30 @@ module OASISTypes = struct type args = string list type command_line = (prog * arg list) + type findlib_name = string type findlib_full = string + type compiled_object = | Byte | Native | Best + type dependency = | FindlibPackage of findlib_full * OASISVersion.comparator option | InternalLibrary of name + type tool = | ExternalTool of name | InternalExecutable of name + type vcs = | Darcs | Git @@ -989,6 +1083,7 @@ module OASISTypes = struct | OtherVCS of url + type plugin_kind = [ `Configure | `Build @@ -998,6 +1093,7 @@ module OASISTypes = struct | `Extra ] + type plugin_data_purpose = [ `Configure | `Build @@ -1012,16 +1108,22 @@ module OASISTypes = struct | `Other of string ] + type 'a plugin = 'a * name * OASISVersion.t option + type all_plugin = plugin_kind plugin + type plugin_data = (all_plugin * plugin_data_purpose * (unit -> unit)) list -(* # 102 "src/oasis/OASISTypes.ml" *) + +(* # 115 "src/oasis/OASISTypes.ml" *) + type 'a conditional = 'a OASISExpr.choices + type custom = { pre_command: (command_line option) conditional; @@ -1029,6 +1131,7 @@ module OASISTypes = struct } + type common_section = { cs_name: name; @@ -1037,6 +1140,7 @@ module OASISTypes = struct } + type build_section = { bs_build: bool conditional; @@ -1056,6 +1160,7 @@ module OASISTypes = struct } + type library = { lib_modules: string list; @@ -1066,18 +1171,28 @@ module OASISTypes = struct lib_findlib_containers: findlib_name list; } + + type object_ = + { + obj_modules: string list; + obj_findlib_fullname: findlib_name list option; + } + + type executable = { exec_custom: bool; exec_main_is: unix_filename; } + type flag = { flag_description: string option; flag_default: bool conditional; } + type source_repository = { src_repo_type: vcs; @@ -1089,6 +1204,7 @@ module OASISTypes = struct src_repo_subdir: unix_filename option; } + type test = { test_type: [`Test] plugin; @@ -1099,6 +1215,7 @@ module OASISTypes = struct test_tools: tool list; } + type doc_format = | HTML of unix_filename | DocText @@ -1109,6 +1226,7 @@ module OASISTypes = struct | OtherDoc + type doc = { doc_type: [`Doc] plugin; @@ -1124,8 +1242,10 @@ module OASISTypes = struct doc_build_tools: tool list; } + type section = | Library of common_section * build_section * library + | Object of common_section * build_section * object_ | Executable of common_section * build_section * executable | Flag of common_section * flag | SrcRepo of common_section * source_repository @@ -1133,14 +1253,18 @@ module OASISTypes = struct | Doc of common_section * doc + type section_kind = - [ `Library | `Executable | `Flag | `SrcRepo | `Test | `Doc ] + [ `Library | `Object | `Executable | `Flag | `SrcRepo | `Test | `Doc ] + - type package = + type package = { oasis_version: OASISVersion.t; ocaml_version: OASISVersion.comparator option; findlib_version: OASISVersion.comparator option; + alpha_features: string list; + beta_features: string list; name: package_name; version: OASISVersion.t; license: OASISLicense.t; @@ -1173,24 +1297,347 @@ module OASISTypes = struct plugin_data: plugin_data; } + +end + +module OASISFeatures = struct +(* # 22 "src/oasis/OASISFeatures.ml" *) + + open OASISTypes + open OASISUtils + open OASISGettext + open OASISVersion + + module MapPlugin = + Map.Make + (struct + type t = plugin_kind * name + let compare = Pervasives.compare + end) + + module Data = + struct + type t = + { + oasis_version: OASISVersion.t; + plugin_versions: OASISVersion.t option MapPlugin.t; + alpha_features: string list; + beta_features: string list; + } + + let create oasis_version alpha_features beta_features = + { + oasis_version = oasis_version; + plugin_versions = MapPlugin.empty; + alpha_features = alpha_features; + beta_features = beta_features + } + + let of_package pkg = + create + pkg.OASISTypes.oasis_version + pkg.OASISTypes.alpha_features + pkg.OASISTypes.beta_features + + let add_plugin (plugin_kind, plugin_name, plugin_version) t = + {t with + plugin_versions = MapPlugin.add + (plugin_kind, plugin_name) + plugin_version + t.plugin_versions} + + let plugin_version plugin_kind plugin_name t = + MapPlugin.find (plugin_kind, plugin_name) t.plugin_versions + end + + type origin = + | Field of string * string + | Section of string + | NoOrigin + + type stage = Alpha | Beta + + + let string_of_stage = + function + | Alpha -> "alpha" + | Beta -> "beta" + + + let field_of_stage = + function + | Alpha -> "AlphaFeatures" + | Beta -> "BetaFeatures" + + type publication = InDev of stage | SinceVersion of OASISVersion.t + + type t = + { + name: string; + plugin: all_plugin option; + publication: publication; + description: unit -> string; + } + + (* TODO: mutex protect this. *) + let all_features = Hashtbl.create 13 + + + let since_version ver_str = SinceVersion (version_of_string ver_str) + let alpha = InDev Alpha + let beta = InDev Beta + + + let data_check t data origin = + let no_message = "no message" in + + let check_feature features stage = + let has_feature = List.mem t.name features in + if not has_feature then + match origin with + | Field (fld, where) -> + Some + (Printf.sprintf + (f_ "Field %s in %s is only available when feature %s \ + is in field %s.") + fld where t.name (field_of_stage stage)) + | Section sct -> + Some + (Printf.sprintf + (f_ "Section %s is only available when features %s \ + is in field %s.") + sct t.name (field_of_stage stage)) + | NoOrigin -> + Some no_message + else + None + in + + let version_is_good ~min_version version fmt = + let version_is_good = + OASISVersion.comparator_apply + version (OASISVersion.VGreaterEqual min_version) + in + Printf.ksprintf + (fun str -> + if version_is_good then + None + else + Some str) + fmt + in + + match origin, t.plugin, t.publication with + | _, _, InDev Alpha -> check_feature data.Data.alpha_features Alpha + | _, _, InDev Beta -> check_feature data.Data.beta_features Beta + | Field(fld, where), None, SinceVersion min_version -> + version_is_good ~min_version data.Data.oasis_version + (f_ "Field %s in %s is only valid since OASIS v%s, update \ + OASISFormat field from '%s' to '%s' after checking \ + OASIS changelog.") + fld where (string_of_version min_version) + (string_of_version data.Data.oasis_version) + (string_of_version min_version) + + | Field(fld, where), Some(plugin_knd, plugin_name, _), + SinceVersion min_version -> + begin + try + let plugin_version_current = + try + match Data.plugin_version plugin_knd plugin_name data with + | Some ver -> ver + | None -> + failwithf + (f_ "Field %s in %s is only valid for the OASIS \ + plugin %s since v%s, but no plugin version is \ + defined in the _oasis file, change '%s' to \ + '%s (%s)' in your _oasis file.") + fld where plugin_name (string_of_version min_version) + plugin_name + plugin_name (string_of_version min_version) + with Not_found -> + failwithf + (f_ "Field %s in %s is only valid when the OASIS plugin %s \ + is defined.") + fld where plugin_name + in + version_is_good ~min_version plugin_version_current + (f_ "Field %s in %s is only valid for the OASIS plugin %s \ + since v%s, update your plugin from '%s (%s)' to \ + '%s (%s)' after checking the plugin's changelog.") + fld where plugin_name (string_of_version min_version) + plugin_name (string_of_version plugin_version_current) + plugin_name (string_of_version min_version) + with Failure msg -> + Some msg + end + + | Section sct, None, SinceVersion min_version -> + version_is_good ~min_version data.Data.oasis_version + (f_ "Section %s is only valid for since OASIS v%s, update \ + OASISFormat field from '%s' to '%s' after checking OASIS \ + changelog.") + sct (string_of_version min_version) + (string_of_version data.Data.oasis_version) + (string_of_version min_version) + + | Section sct, Some(plugin_knd, plugin_name, _), + SinceVersion min_version -> + begin + try + let plugin_version_current = + try + match Data.plugin_version plugin_knd plugin_name data with + | Some ver -> ver + | None -> + failwithf + (f_ "Section %s is only valid for the OASIS \ + plugin %s since v%s, but no plugin version is \ + defined in the _oasis file, change '%s' to \ + '%s (%s)' in your _oasis file.") + sct plugin_name (string_of_version min_version) + plugin_name + plugin_name (string_of_version min_version) + with Not_found -> + failwithf + (f_ "Section %s is only valid when the OASIS plugin %s \ + is defined.") + sct plugin_name + in + version_is_good ~min_version plugin_version_current + (f_ "Section %s is only valid for the OASIS plugin %s \ + since v%s, update your plugin from '%s (%s)' to \ + '%s (%s)' after checking the plugin's changelog.") + sct plugin_name (string_of_version min_version) + plugin_name (string_of_version plugin_version_current) + plugin_name (string_of_version min_version) + with Failure msg -> + Some msg + end + + | NoOrigin, None, SinceVersion min_version -> + version_is_good ~min_version data.Data.oasis_version "%s" no_message + + | NoOrigin, Some(plugin_knd, plugin_name, _), SinceVersion min_version -> + begin + try + let plugin_version_current = + match Data.plugin_version plugin_knd plugin_name data with + | Some ver -> ver + | None -> raise Not_found + in + version_is_good ~min_version plugin_version_current + "%s" no_message + with Not_found -> + Some no_message + end + + + let data_assert t data origin = + match data_check t data origin with + | None -> () + | Some str -> failwith str + + + let data_test t data = + match data_check t data NoOrigin with + | None -> true + | Some str -> false + + + let package_test t pkg = + data_test t (Data.of_package pkg) + + + let create ?plugin name publication description = + let () = + if Hashtbl.mem all_features name then + failwithf "Feature '%s' is already declared." name + in + let t = + { + name = name; + plugin = plugin; + publication = publication; + description = description; + } + in + Hashtbl.add all_features name t; + t + + + let get_stage name = + try + (Hashtbl.find all_features name).publication + with Not_found -> + failwithf (f_ "Feature %s doesn't exist.") name + + + let list () = + Hashtbl.fold (fun _ v acc -> v :: acc) all_features [] + + (* + * Real flags. + *) + + + let features = + create "features_fields" + (since_version "0.4") + (fun () -> + s_ "Enable to experiment not yet official features.") + + + let flag_docs = + create "flag_docs" + (since_version "0.3") + (fun () -> + s_ "Building docs require '-docs' flag at configure.") + + + let flag_tests = + create "flag_tests" + (since_version "0.3") + (fun () -> + s_ "Running tests require '-tests' flag at configure.") + + + let pack = + create "pack" + (since_version "0.3") + (fun () -> + s_ "Allow to create packed library.") + + + let section_object = + create "section_object" beta + (fun () -> + s_ "Implement an object section.") end module OASISUnixPath = struct -(* # 21 "src/oasis/OASISUnixPath.ml" *) +(* # 22 "src/oasis/OASISUnixPath.ml" *) + type unix_filename = string type unix_dirname = string + type host_filename = string type host_dirname = string + let current_dir_name = "." + let parent_dir_name = ".." + let is_current_dir fn = fn = current_dir_name || fn = "" + let concat f1 f2 = if is_current_dir f1 then f2 @@ -1200,6 +1647,7 @@ module OASISUnixPath = struct in f1'^"/"^f2 + let make = function | hd :: tl -> @@ -1210,12 +1658,14 @@ module OASISUnixPath = struct | [] -> invalid_arg "OASISUnixPath.make" + let dirname f = try String.sub f 0 (String.rindex f '/') with Not_found -> current_dir_name + let basename f = try let pos_start = @@ -1225,6 +1675,7 @@ module OASISUnixPath = struct with Not_found -> f + let chop_extension f = try let last_dot = @@ -1247,26 +1698,31 @@ module OASISUnixPath = struct with Not_found -> f + let capitalize_file f = let dir = dirname f in let base = basename f in concat dir (String.capitalize base) + let uncapitalize_file f = let dir = dirname f in let base = basename f in concat dir (String.uncapitalize base) + end module OASISHostPath = struct -(* # 21 "src/oasis/OASISHostPath.ml" *) +(* # 22 "src/oasis/OASISHostPath.ml" *) open Filename + module Unix = OASISUnixPath + let make = function | [] -> @@ -1274,6 +1730,7 @@ module OASISHostPath = struct | hd :: tl -> List.fold_left Filename.concat hd tl + let of_unix ufn = if Sys.os_type = "Unix" then ufn @@ -1293,14 +1750,18 @@ module OASISHostPath = struct end module OASISSection = struct -(* # 21 "src/oasis/OASISSection.ml" *) +(* # 22 "src/oasis/OASISSection.ml" *) + open OASISTypes - let section_kind_common = + + let section_kind_common = function - | Library (cs, _, _) -> + | Library (cs, _, _) -> `Library, cs + | Object (cs, _, _) -> + `Object, cs | Executable (cs, _, _) -> `Executable, cs | Flag (cs, _) -> @@ -1312,32 +1773,38 @@ module OASISSection = struct | Doc (cs, _) -> `Doc, cs + let section_common sct = snd (section_kind_common sct) + let section_common_set cs = function | Library (_, bs, lib) -> Library (cs, bs, lib) + | Object (_, bs, obj) -> Object (cs, bs, obj) | Executable (_, bs, exec) -> Executable (cs, bs, exec) | Flag (_, flg) -> Flag (cs, flg) | SrcRepo (_, src_repo) -> SrcRepo (cs, src_repo) | Test (_, tst) -> Test (cs, tst) | Doc (_, doc) -> Doc (cs, doc) + (** Key used to identify section *) - let section_id sct = - let k, cs = + let section_id sct = + let k, cs = section_kind_common sct in k, cs.cs_name + let string_of_section sct = let k, nm = section_id sct in (match k with - | `Library -> "library" + | `Library -> "library" + | `Object -> "object" | `Executable -> "executable" | `Flag -> "flag" | `SrcRepo -> "src repository" @@ -1345,20 +1812,22 @@ module OASISSection = struct | `Doc -> "doc") ^" "^nm + let section_find id scts = List.find (fun sct -> id = section_id sct) scts + module CSection = struct type t = section let id = section_id - let compare t1 t2 = + let compare t1 t2 = compare (id t1) (id t2) - + let equal t1 t2 = (id t1) = (id t2) @@ -1366,28 +1835,33 @@ module OASISSection = struct Hashtbl.hash (id t) end + module MapSection = Map.Make(CSection) module SetSection = Set.Make(CSection) + end module OASISBuildSection = struct -(* # 21 "src/oasis/OASISBuildSection.ml" *) +(* # 22 "src/oasis/OASISBuildSection.ml" *) + end module OASISExecutable = struct -(* # 21 "src/oasis/OASISExecutable.ml" *) +(* # 22 "src/oasis/OASISExecutable.ml" *) + open OASISTypes - let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = - let dir = + + let unix_exec_is (cs, bs, exec) is_native ext_dll suffix_program = + let dir = OASISUnixPath.concat bs.bs_path (OASISUnixPath.dirname exec.exec_main_is) in - let is_native_exec = + let is_native_exec = match bs.bs_compiled_object with | Native -> true | Best -> is_native () @@ -1398,40 +1872,28 @@ module OASISExecutable = struct dir (cs.cs_name^(suffix_program ())), - if not is_native_exec && - not exec.exec_custom && + if not is_native_exec && + not exec.exec_custom && bs.bs_c_sources <> [] then Some (dir^"/dll"^cs.cs_name^"_stubs"^(ext_dll ())) else None + end module OASISLibrary = struct -(* # 21 "src/oasis/OASISLibrary.ml" *) +(* # 22 "src/oasis/OASISLibrary.ml" *) + open OASISTypes open OASISUtils open OASISGettext open OASISSection - type library_name = name - type findlib_part_name = name - type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t - - exception InternalLibraryNotFound of library_name - exception FindlibPackageNotFound of findlib_name - - type group_t = - | Container of findlib_name * group_t list - | Package of (findlib_name * - common_section * - build_section * - library * - group_t list) (* Look for a module file, considering capitalization or not. *) - let find_module source_file_exists (cs, bs, lib) modul = + let find_module source_file_exists bs modul = let possible_base_fn = List.map (OASISUnixPath.concat bs.bs_path) @@ -1469,10 +1931,11 @@ module OASISLibrary = struct (`No_sources possible_base_fn) possible_base_fn + let source_unix_files ~ctxt (cs, bs, lib) source_file_exists = List.fold_left (fun acc modul -> - match find_module source_file_exists (cs, bs, lib) modul with + match find_module source_file_exists bs modul with | `Sources (base_fn, lst) -> (base_fn, lst) :: acc | `No_sources _ -> @@ -1485,6 +1948,7 @@ module OASISLibrary = struct [] (lib.lib_modules @ lib.lib_internal_modules) + let generated_unix_files ~ctxt ~is_native @@ -1494,24 +1958,29 @@ module OASISLibrary = struct ~source_file_exists (cs, bs, lib) = - let find_modules lst ext = + let find_modules lst ext = let find_module modul = - match find_module source_file_exists (cs, bs, lib) modul with + match find_module source_file_exists bs modul with + | `Sources (base_fn, [fn]) when ext <> "cmi" + && Filename.check_suffix fn ".mli" -> + None (* No implementation files for pure interface. *) | `Sources (base_fn, _) -> - [base_fn] + Some [base_fn] | `No_sources lst -> OASISMessage.warning ~ctxt (f_ "Cannot find source file matching \ module '%s' in library %s") modul cs.cs_name; - lst + Some lst in - List.map - (fun nm -> - List.map - (fun base_fn -> base_fn ^"."^ext) - (find_module nm)) + List.fold_left + (fun acc nm -> + match find_module nm with + | None -> acc + | Some base_fns -> + List.map (fun base_fn -> base_fn ^"."^ext) base_fns :: acc) + [] lst in @@ -1528,16 +1997,20 @@ module OASISLibrary = struct (* The .cmx that be compiled along *) let cmxs = let should_be_built = - (not lib.lib_pack) && (* Do not install .cmx packed submodules *) match bs.bs_compiled_object with | Native -> true | Best -> is_native | Byte -> false in if should_be_built then - find_modules - (lib.lib_modules @ lib.lib_internal_modules) - "cmx" + if lib.lib_pack then + find_modules + [cs.cs_name] + "cmx" + else + find_modules + (lib.lib_modules @ lib.lib_internal_modules) + "cmx" else [] in @@ -1559,7 +2032,7 @@ module OASISLibrary = struct add_pack_header ([cs.cs_name^".cma"] :: acc) in let native acc = - let acc = + let acc = add_pack_header (if has_native_dynlink then [cs.cs_name^".cmxs"] :: acc @@ -1598,11 +2071,113 @@ module OASISLibrary = struct acc_nopath) (headers @ cmxs) - type data = common_section * build_section * library + +end + +module OASISObject = struct +(* # 22 "src/oasis/OASISObject.ml" *) + + + open OASISTypes + open OASISGettext + + + let source_unix_files ~ctxt (cs, bs, obj) source_file_exists = + List.fold_left + (fun acc modul -> + match OASISLibrary.find_module source_file_exists bs modul with + | `Sources (base_fn, lst) -> + (base_fn, lst) :: acc + | `No_sources _ -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in object %s") + modul cs.cs_name; + acc) + [] + obj.obj_modules + + + let generated_unix_files + ~ctxt + ~is_native + ~source_file_exists + (cs, bs, obj) = + + let find_module ext modul = + match OASISLibrary.find_module source_file_exists bs modul with + | `Sources (base_fn, _) -> [base_fn ^ ext] + | `No_sources lst -> + OASISMessage.warning + ~ctxt + (f_ "Cannot find source file matching \ + module '%s' in object %s") + modul cs.cs_name ; + lst + in + + let header, byte, native, c_object, f = + match obj.obj_modules with + | [ m ] -> (find_module ".cmi" m, + find_module ".cmo" m, + find_module ".cmx" m, + find_module ".o" m, + fun x -> x) + | _ -> ([cs.cs_name ^ ".cmi"], + [cs.cs_name ^ ".cmo"], + [cs.cs_name ^ ".cmx"], + [cs.cs_name ^ ".o"], + OASISUnixPath.concat bs.bs_path) + in + List.map (List.map f) ( + match bs.bs_compiled_object with + | Native -> + native :: c_object :: byte :: header :: [] + | Best when is_native -> + native :: c_object :: byte :: header :: [] + | Byte | Best -> + byte :: header :: []) + + +end + +module OASISFindlib = struct +(* # 22 "src/oasis/OASISFindlib.ml" *) + + + open OASISTypes + open OASISUtils + open OASISGettext + open OASISSection + + + type library_name = name + type findlib_part_name = name + type 'a map_of_findlib_part_name = 'a OASISUtils.MapString.t + + + exception InternalLibraryNotFound of library_name + exception FindlibPackageNotFound of findlib_name + + + type group_t = + | Container of findlib_name * group_t list + | Package of (findlib_name * + common_section * + build_section * + [`Library of library | `Object of object_] * + group_t list) + + + type data = common_section * + build_section * + [`Library of library | `Object of object_] type tree = | Node of (data option) * (tree MapString.t) | Leaf of data + let findlib_mapping pkg = (* Map from library name to either full findlib name or parts + parent. *) let fndlb_parts_of_lib_name = @@ -1641,6 +2216,23 @@ module OASISLibrary = struct mp end + | Object (cs, _, obj) -> + begin + let obj_name = cs.cs_name in + if MapString.mem obj_name mp then + failwithf + (f_ "The object name '%s' is used more than once.") + obj_name; + let findlib_full_name = match obj.obj_findlib_fullname with + | Some ns -> String.concat "." ns + | None -> obj_name + in + MapString.add + obj_name + (`Solved findlib_full_name) + mp + end + | Executable _ | Test _ | Flag _ | SrcRepo _ | Doc _ -> mp) MapString.empty @@ -1708,7 +2300,7 @@ module OASISLibrary = struct let lib_name = cs.cs_name in findlib_name_of_library_name lib_name in - let rec add_children nm_lst (children : tree MapString.t) = + let rec add_children nm_lst (children: tree MapString.t) = match nm_lst with | (hd :: tl) -> begin @@ -1778,7 +2370,9 @@ module OASISLibrary = struct (fun mp -> function | Library (cs, bs, lib) -> - add (cs, bs, lib) mp + add (cs, bs, `Library lib) mp + | Object (cs, bs, obj) -> + add (cs, bs, `Object obj) mp | _ -> mp) MapString.empty @@ -1809,11 +2403,13 @@ module OASISLibrary = struct findlib_name_of_library_name, library_name_of_findlib_name + let findlib_of_group = function | Container (fndlb_nm, _) | Package (fndlb_nm, _, _, _, _) -> fndlb_nm + let root_of_group grp = let rec root_lib_aux = (* We do a DFS in the group. *) @@ -1838,40 +2434,48 @@ module OASISLibrary = struct (f_ "Unable to determine root library of findlib library '%s'") (findlib_of_group grp) + end module OASISFlag = struct -(* # 21 "src/oasis/OASISFlag.ml" *) +(* # 22 "src/oasis/OASISFlag.ml" *) + end module OASISPackage = struct -(* # 21 "src/oasis/OASISPackage.ml" *) +(* # 22 "src/oasis/OASISPackage.ml" *) + end module OASISSourceRepository = struct -(* # 21 "src/oasis/OASISSourceRepository.ml" *) +(* # 22 "src/oasis/OASISSourceRepository.ml" *) + end module OASISTest = struct -(* # 21 "src/oasis/OASISTest.ml" *) +(* # 22 "src/oasis/OASISTest.ml" *) + end module OASISDocument = struct -(* # 21 "src/oasis/OASISDocument.ml" *) +(* # 22 "src/oasis/OASISDocument.ml" *) + end module OASISExec = struct -(* # 21 "src/oasis/OASISExec.ml" *) +(* # 22 "src/oasis/OASISExec.ml" *) + open OASISGettext open OASISUtils open OASISMessage + (* TODO: I don't like this quote, it is there because $(rm) foo expands to * 'rm -f' foo... *) @@ -1902,6 +2506,7 @@ module OASISExec = struct | Some f, i -> f i + let run_read_output ~ctxt ?f_exit_code cmd args = let fn = Filename.temp_file "oasis-" ".txt" @@ -1933,6 +2538,7 @@ module OASISExec = struct (try Sys.remove fn with _ -> ()); raise e + let run_read_one_line ~ctxt ?f_exit_code cmd args = match run_read_output ~ctxt ?f_exit_code cmd args with | [fst] -> @@ -1944,10 +2550,12 @@ module OASISExec = struct end module OASISFileUtil = struct -(* # 21 "src/oasis/OASISFileUtil.ml" *) +(* # 22 "src/oasis/OASISFileUtil.ml" *) + open OASISGettext + let file_exists_case fn = let dirname = Filename.dirname fn in let basename = Filename.basename fn in @@ -1961,6 +2569,7 @@ module OASISFileUtil = struct else false + let find_file ?(case_sensitive=true) paths exts = (* Cardinal product of two list *) @@ -1969,7 +2578,7 @@ module OASISFileUtil = struct (List.map (fun a -> List.map - (fun b -> a,b) + (fun b -> a, b) lst2) lst1) in @@ -1979,7 +2588,7 @@ module OASISFileUtil = struct | p1 :: p2 :: tl -> let acc = (List.map - (fun (a,b) -> Filename.concat a b) + (fun (a, b) -> Filename.concat a b) (p1 * p2)) in combined_paths (acc :: tl) @@ -1991,19 +2600,21 @@ module OASISFileUtil = struct let alternatives = List.map - (fun (p,e) -> + (fun (p, e) -> if String.length e > 0 && e.[0] <> '.' then p ^ "." ^ e else p ^ e) ((combined_paths paths) * exts) in - List.find + List.find (fun file -> (if case_sensitive then - file_exists_case + file_exists_case file else - Sys.file_exists) - alternatives + Sys.file_exists file) + && not (Sys.is_directory file) + ) alternatives + let which ~ctxt prg = let path_sep = @@ -2023,6 +2634,7 @@ module OASISFileUtil = struct in find_file ~case_sensitive:false [path_lst; [prg]] exec_ext + (**/**) let rec fix_dir dn = (* Windows hack because Sys.file_exists "src\\" = false when @@ -2036,9 +2648,11 @@ module OASISFileUtil = struct else dn + let q = Filename.quote (**/**) + let cp ~ctxt ?(recurse=false) src tgt = if recurse then match Sys.os_type with @@ -2055,6 +2669,7 @@ module OASISFileUtil = struct | _ -> "cp") [q src; q tgt] + let mkdir ~ctxt tgt = OASISExec.run ~ctxt (match Sys.os_type with @@ -2062,6 +2677,7 @@ module OASISFileUtil = struct | _ -> "mkdir") [q tgt] + let rec mkdir_parent ~ctxt f tgt = let tgt = fix_dir tgt @@ -2084,6 +2700,7 @@ module OASISFileUtil = struct end end + let rmdir ~ctxt tgt = if Sys.readdir tgt = [||] then begin @@ -2094,6 +2711,7 @@ module OASISFileUtil = struct OASISExec.run ~ctxt "rm" ["-r"; q tgt] end + let glob ~ctxt fn = let basename = Filename.basename fn @@ -2139,19 +2757,23 @@ module OASISFileUtil = struct end -# 2142 "setup.ml" +# 2760 "setup.ml" module BaseEnvLight = struct -(* # 21 "src/base/BaseEnvLight.ml" *) +(* # 22 "src/base/BaseEnvLight.ml" *) + module MapString = Map.Make(String) + type t = string MapString.t + let default_filename = Filename.concat (Sys.getcwd ()) "setup.data" + let load ?(allow_empty=false) ?(filename=default_filename) () = if Sys.file_exists filename then begin @@ -2209,6 +2831,7 @@ module BaseEnvLight = struct filename) end + let var_get name env = let rec var_expand str = let buff = @@ -2230,6 +2853,7 @@ module BaseEnvLight = struct in var_expand (MapString.find name env) + let var_choose lst env = OASISExpr.choose (fun nm -> var_get nm env) @@ -2237,20 +2861,24 @@ module BaseEnvLight = struct end -# 2240 "setup.ml" +# 2864 "setup.ml" module BaseContext = struct -(* # 21 "src/base/BaseContext.ml" *) +(* # 22 "src/base/BaseContext.ml" *) + open OASISContext + let args = args + let default = default end module BaseMessage = struct -(* # 21 "src/base/BaseMessage.ml" *) +(* # 22 "src/base/BaseMessage.ml" *) + (** Message to user, overrid for Base @author Sylvain Le Gall @@ -2258,31 +2886,38 @@ module BaseMessage = struct open OASISMessage open BaseContext + let debug fmt = debug ~ctxt:!default fmt + let info fmt = info ~ctxt:!default fmt + let warning fmt = warning ~ctxt:!default fmt + let error fmt = error ~ctxt:!default fmt end module BaseEnv = struct -(* # 21 "src/base/BaseEnv.ml" *) +(* # 22 "src/base/BaseEnv.ml" *) open OASISGettext open OASISUtils open PropList + module MapString = BaseEnvLight.MapString + type origin_t = | ODefault | OGetEnv | OFileLoad | OCommandLine + type cli_handle_t = | CLINone | CLIAuto @@ -2290,6 +2925,7 @@ module BaseEnv = struct | CLIEnable | CLIUser of (Arg.key * Arg.spec * Arg.doc) list + type definition_t = { hide: bool; @@ -2299,21 +2935,26 @@ module BaseEnv = struct group: string option; } + let schema = Schema.create "environment" + (* Environment data *) let env = Data.create () + (* Environment data from file *) let env_from_file = ref MapString.empty + (* Lexer for var *) let var_lxr = Genlex.make_lexer [] + let rec var_expand str = let buff = Buffer.create ((String.length str) * 2) @@ -2364,6 +3005,7 @@ module BaseEnv = struct str; Buffer.contents buff + and var_get name = let vl = try @@ -2378,6 +3020,7 @@ module BaseEnv = struct in var_expand vl + let var_choose ?printer ?name lst = OASISExpr.choose ?printer @@ -2385,6 +3028,7 @@ module BaseEnv = struct var_get lst + let var_protect vl = let buff = Buffer.create (String.length vl) @@ -2396,6 +3040,7 @@ module BaseEnv = struct vl; Buffer.contents buff + let var_define ?(hide=false) ?(dump=true) @@ -2481,6 +3126,7 @@ module BaseEnv = struct fun () -> var_expand (var_get_low (var_get_lst env)) + let var_redefine ?hide ?dump @@ -2509,8 +3155,9 @@ module BaseEnv = struct dflt end - let var_ignore (e : unit -> string) = - () + + let var_ignore (e: unit -> string) = () + let print_hidden = var_define @@ -2521,6 +3168,7 @@ module BaseEnv = struct "print_hidden" (fun () -> "false") + let var_all () = List.rev (Schema.fold @@ -2532,24 +3180,28 @@ module BaseEnv = struct [] schema) + let default_filename = BaseEnvLight.default_filename + let load ?allow_empty ?filename () = env_from_file := BaseEnvLight.load ?allow_empty ?filename () + let unload () = env_from_file := MapString.empty; Data.clear env + let dump ?(filename=default_filename) () = let chn = open_out_bin filename in - let output nm value = + let output nm value = Printf.fprintf chn "%s=%S\n" nm value in - let mp_todo = + let mp_todo = (* Dump data from schema *) Schema.fold (fun mp_todo nm def _ -> @@ -2576,6 +3228,7 @@ module BaseEnv = struct (* End of the dump *) close_out chn + let print () = let printable_vars = Schema.fold @@ -2614,11 +3267,12 @@ module BaseEnv = struct Printf.printf "\nConfiguration: \n"; List.iter - (fun (name,value) -> + (fun (name, value) -> Printf.printf "%s: %s %s\n" name (dot_pad name) value) (List.rev printable_vars); Printf.printf "\n%!" + let args () = let arg_concat = OASISUtils.varname_concat ~hyphen:'-' @@ -2729,11 +3383,13 @@ module BaseEnv = struct end module BaseArgExt = struct -(* # 21 "src/base/BaseArgExt.ml" *) +(* # 22 "src/base/BaseArgExt.ml" *) + open OASISUtils open OASISGettext + let parse argv args = (* Simulate command line for Arg *) let current = @@ -2757,13 +3413,15 @@ module BaseArgExt = struct end module BaseCheck = struct -(* # 21 "src/base/BaseCheck.ml" *) +(* # 22 "src/base/BaseCheck.ml" *) + open BaseEnv open BaseMessage open OASISUtils open OASISGettext + let prog_best prg prg_lst = var_redefine prg @@ -2786,15 +3444,19 @@ module BaseCheck = struct | Some prg -> prg | None -> raise Not_found) + let prog prg = prog_best prg [prg] + let prog_opt prg = prog_best prg [prg^".opt"; prg] + let ocamlfind = prog "ocamlfind" + let version var_prefix cmp @@ -2836,11 +3498,13 @@ module BaseCheck = struct version_str) () + let package_version pkg = OASISExec.run_read_one_line ~ctxt:!BaseContext.default (ocamlfind ()) ["query"; "-format"; "%v"; pkg] + let package ?version_comparator pkg () = let var = OASISUtils.varname_concat @@ -2883,18 +3547,21 @@ module BaseCheck = struct end module BaseOCamlcConfig = struct -(* # 21 "src/base/BaseOCamlcConfig.ml" *) +(* # 22 "src/base/BaseOCamlcConfig.ml" *) open BaseEnv open OASISUtils open OASISGettext + module SMap = Map.Make(String) + let ocamlc = BaseCheck.prog_opt "ocamlc" + let ocamlc_config_map = (* Map name to value for ocamlc -config output (name ^": "^value) @@ -2940,7 +3607,7 @@ module BaseOCamlcConfig = struct mp in - let cache = + let cache = lazy (var_protect (Marshal.to_string @@ -2959,6 +3626,7 @@ module BaseOCamlcConfig = struct (* TODO: update if ocamlc change !!! *) Lazy.force cache) + let var_define nm = (* Extract data from ocamlc -config *) let avlbl_config_get () = @@ -2967,15 +3635,15 @@ module BaseOCamlcConfig = struct 0 in let chop_version_suffix s = - try + try String.sub s 0 (String.index s '+') - with _ -> + with _ -> s in let nm_config, value_config = match nm with - | "ocaml_version" -> + | "ocaml_version" -> "version", chop_version_suffix | _ -> nm, (fun x -> x) in @@ -2999,7 +3667,7 @@ module BaseOCamlcConfig = struct end module BaseStandardVar = struct -(* # 21 "src/base/BaseStandardVar.ml" *) +(* # 22 "src/base/BaseStandardVar.ml" *) open OASISGettext @@ -3008,6 +3676,7 @@ module BaseStandardVar = struct open BaseCheck open BaseEnv + let ocamlfind = BaseCheck.ocamlfind let ocamlc = BaseOCamlcConfig.ocamlc let ocamlopt = prog_opt "ocamlopt" @@ -3018,13 +3687,16 @@ module BaseStandardVar = struct let rpkg = ref None + let pkg_get () = match !rpkg with | Some pkg -> pkg | None -> failwith (s_ "OASIS Package is not set") + let var_cond = ref [] + let var_define_cond ~since_version f dflt = let holder = ref (fun () -> dflt) in let since_version = @@ -3036,14 +3708,17 @@ module BaseStandardVar = struct holder := f ()) :: !var_cond; fun () -> !holder () + (**/**) + let pkg_name = var_define ~short_desc:(fun () -> s_ "Package name") "pkg_name" (fun () -> (pkg_get ()).name) + let pkg_version = var_define ~short_desc:(fun () -> s_ "Package version") @@ -3051,16 +3726,20 @@ module BaseStandardVar = struct (fun () -> (OASISVersion.string_of_version (pkg_get ()).version)) + let c = BaseOCamlcConfig.var_define + let os_type = c "os_type" let system = c "system" let architecture = c "architecture" let ccomp_type = c "ccomp_type" let ocaml_version = c "ocaml_version" + (* TODO: Check standard variable presence at runtime *) + let standard_library_default = c "standard_library_default" let standard_library = c "standard_library" let standard_runtime = c "standard_runtime" @@ -3074,24 +3753,27 @@ module BaseStandardVar = struct let default_executable_name = c "default_executable_name" let systhread_supported = c "systhread_supported" - let flexlink = + + let flexlink = BaseCheck.prog "flexlink" + let flexdll_version = var_define ~short_desc:(fun () -> "FlexDLL version (Win32)") "flexdll_version" (fun () -> - let lst = + let lst = OASISExec.run_read_output ~ctxt:!BaseContext.default (flexlink ()) ["-help"] in - match lst with + match lst with | line :: _ -> Scanf.sscanf line "FlexDLL version %s" (fun ver -> ver) | [] -> raise Not_found) + (**/**) let p name hlp dflt = var_define @@ -3101,6 +3783,7 @@ module BaseStandardVar = struct name dflt + let (/) a b = if os_type () = Sys.os_type then Filename.concat a b @@ -3111,6 +3794,7 @@ module BaseStandardVar = struct (os_type ()) (**/**) + let prefix = p "prefix" (fun () -> s_ "Install architecture-independent files dir") @@ -3124,96 +3808,115 @@ module BaseStandardVar = struct | _ -> "/usr/local") + let exec_prefix = p "exec_prefix" (fun () -> s_ "Install architecture-dependent files in dir") (fun () -> "$prefix") + let bindir = p "bindir" (fun () -> s_ "User executables") (fun () -> "$exec_prefix"/"bin") + let sbindir = p "sbindir" (fun () -> s_ "System admin executables") (fun () -> "$exec_prefix"/"sbin") + let libexecdir = p "libexecdir" (fun () -> s_ "Program executables") (fun () -> "$exec_prefix"/"libexec") + let sysconfdir = p "sysconfdir" (fun () -> s_ "Read-only single-machine data") (fun () -> "$prefix"/"etc") + let sharedstatedir = p "sharedstatedir" (fun () -> s_ "Modifiable architecture-independent data") (fun () -> "$prefix"/"com") + let localstatedir = p "localstatedir" (fun () -> s_ "Modifiable single-machine data") (fun () -> "$prefix"/"var") + let libdir = p "libdir" (fun () -> s_ "Object code libraries") (fun () -> "$exec_prefix"/"lib") + let datarootdir = p "datarootdir" (fun () -> s_ "Read-only arch-independent data root") (fun () -> "$prefix"/"share") + let datadir = p "datadir" (fun () -> s_ "Read-only architecture-independent data") (fun () -> "$datarootdir") + let infodir = p "infodir" (fun () -> s_ "Info documentation") (fun () -> "$datarootdir"/"info") + let localedir = p "localedir" (fun () -> s_ "Locale-dependent data") (fun () -> "$datarootdir"/"locale") + let mandir = p "mandir" (fun () -> s_ "Man documentation") (fun () -> "$datarootdir"/"man") + let docdir = p "docdir" (fun () -> s_ "Documentation root") (fun () -> "$datarootdir"/"doc"/"$pkg_name") + let htmldir = p "htmldir" (fun () -> s_ "HTML documentation") (fun () -> "$docdir") + let dvidir = p "dvidir" (fun () -> s_ "DVI documentation") (fun () -> "$docdir") + let pdfdir = p "pdfdir" (fun () -> s_ "PDF documentation") (fun () -> "$docdir") + let psdir = p "psdir" (fun () -> s_ "PS documentation") (fun () -> "$docdir") + let destdir = p "destdir" (fun () -> s_ "Prepend a path when installing package") @@ -3223,35 +3926,39 @@ module BaseStandardVar = struct ("destdir", Some (s_ "undefined by construct")))) + let findlib_version = var_define "findlib_version" (fun () -> BaseCheck.package_version "findlib") + let is_native = var_define "is_native" (fun () -> try - let _s : string = + let _s: string = ocamlopt () in "true" with PropList.Not_set _ -> - let _s : string = + let _s: string = ocamlc () in "false") + let ext_program = var_define "suffix_program" (fun () -> match os_type () with - | "Win32" -> ".exe" + | "Win32" | "Cygwin" -> ".exe" | _ -> "") + let rm = var_define ~short_desc:(fun () -> s_ "Remove a file.") @@ -3261,6 +3968,7 @@ module BaseStandardVar = struct | "Win32" -> "del" | _ -> "rm -f") + let rmdir = var_define ~short_desc:(fun () -> s_ "Remove a directory.") @@ -3270,6 +3978,7 @@ module BaseStandardVar = struct | "Win32" -> "rd" | _ -> "rm -rf") + let debug = var_define ~short_desc:(fun () -> s_ "Turn ocaml debug flag on") @@ -3277,6 +3986,7 @@ module BaseStandardVar = struct "debug" (fun () -> "true") + let profile = var_define ~short_desc:(fun () -> s_ "Turn ocaml profile flag on") @@ -3284,6 +3994,7 @@ module BaseStandardVar = struct "profile" (fun () -> "false") + let tests = var_define_cond ~since_version:"0.3" (fun () -> @@ -3295,6 +4006,7 @@ module BaseStandardVar = struct (fun () -> "false")) "true" + let docs = var_define_cond ~since_version:"0.3" (fun () -> @@ -3305,6 +4017,7 @@ module BaseStandardVar = struct (fun () -> "true")) "true" + let native_dynlink = var_define ~short_desc:(fun () -> s_ "Compiler support generation of .cmxs.") @@ -3312,7 +4025,7 @@ module BaseStandardVar = struct "native_dynlink" (fun () -> let res = - let ocaml_lt_312 () = + let ocaml_lt_312 () = OASISVersion.comparator_apply (OASISVersion.version_of_string (ocaml_version ())) (OASISVersion.VLesser @@ -3324,7 +4037,7 @@ module BaseStandardVar = struct (OASISVersion.VLesser (OASISVersion.version_of_string "0.30")) in - let has_native_dynlink = + let has_native_dynlink = let ocamlfind = ocamlfind () in try let fn = @@ -3342,10 +4055,10 @@ module BaseStandardVar = struct false else if ocaml_lt_312 () then false - else if (os_type () = "Win32" || os_type () = "Cygwin") + else if (os_type () = "Win32" || os_type () = "Cygwin") && flexdll_lt_030 () then begin - BaseMessage.warning + BaseMessage.warning (f_ ".cmxs generation disabled because FlexDLL needs to be \ at least 0.30. Please upgrade FlexDLL from %s to 0.30.") (flexdll_version ()); @@ -3356,6 +4069,7 @@ module BaseStandardVar = struct in string_of_bool res) + let init pkg = rpkg := Some pkg; List.iter (fun f -> f pkg.oasis_version) !var_cond @@ -3363,12 +4077,14 @@ module BaseStandardVar = struct end module BaseFileAB = struct -(* # 21 "src/base/BaseFileAB.ml" *) +(* # 22 "src/base/BaseFileAB.ml" *) + open BaseEnv open OASISGettext open BaseMessage + let to_filename fn = let fn = OASISHostPath.of_unix fn @@ -3379,6 +4095,7 @@ module BaseFileAB = struct fn; Filename.chop_extension fn + let replace fn_lst = let buff = Buffer.create 13 @@ -3411,15 +4128,18 @@ module BaseFileAB = struct end module BaseLog = struct -(* # 21 "src/base/BaseLog.ml" *) +(* # 22 "src/base/BaseLog.ml" *) + open OASISUtils + let default_filename = Filename.concat (Filename.dirname BaseEnv.default_filename) "setup.log" + module SetTupleString = Set.Make (struct @@ -3430,6 +4150,7 @@ module BaseLog = struct | n -> n end) + let load () = if Sys.file_exists default_filename then begin @@ -3479,6 +4200,7 @@ module BaseLog = struct [] end + let register event data = let chn_out = open_out_gen [Open_append; Open_creat; Open_text] 0o644 default_filename @@ -3486,6 +4208,7 @@ module BaseLog = struct Printf.fprintf chn_out "%S %S\n" event data; close_out chn_out + let unregister event data = if Sys.file_exists default_filename then begin @@ -3511,6 +4234,7 @@ module BaseLog = struct Sys.remove default_filename end + let filter events = let st_events = List.fold_left @@ -3523,6 +4247,7 @@ module BaseLog = struct (fun (e, _) -> SetString.mem e st_events) (load ()) + let exists event data = List.exists (fun v -> (event, data) = v) @@ -3530,31 +4255,38 @@ module BaseLog = struct end module BaseBuilt = struct -(* # 21 "src/base/BaseBuilt.ml" *) +(* # 22 "src/base/BaseBuilt.ml" *) + open OASISTypes open OASISGettext open BaseStandardVar open BaseMessage + type t = | BExec (* Executable *) | BExecLib (* Library coming with executable *) | BLib (* Library *) + | BObj (* Library *) | BDoc (* Document *) + let to_log_event_file t nm = "built_"^ (match t with | BExec -> "exec" | BExecLib -> "exec_lib" | BLib -> "lib" + | BObj -> "obj" | BDoc -> "doc")^ "_"^nm + let to_log_event_done t nm = "is_"^(to_log_event_file t nm) + let register t nm lst = BaseLog.register (to_log_event_done t nm) @@ -3585,6 +4317,7 @@ module BaseBuilt = struct (String.concat (s_ ", ") alt)) lst + let unregister t nm = List.iter (fun (e, d) -> @@ -3593,6 +4326,7 @@ module BaseBuilt = struct [to_log_event_file t nm; to_log_event_done t nm]) + let fold t nm f acc = List.fold_left (fun acc (_, fn) -> @@ -3612,6 +4346,8 @@ module BaseBuilt = struct (f_ "executable %s") | BLib -> (f_ "library %s") + | BObj -> + (f_ "object %s") | BDoc -> (f_ "documentation %s")) nm); @@ -3621,6 +4357,7 @@ module BaseBuilt = struct (BaseLog.filter [to_log_event_file t nm]) + let is_built t nm = List.fold_left (fun is_built (_, d) -> @@ -3632,6 +4369,7 @@ module BaseBuilt = struct (BaseLog.filter [to_log_event_done t nm]) + let of_executable ffn (cs, bs, exec) = let unix_exec_is, unix_dll_opt = OASISExecutable.unix_exec_is @@ -3655,6 +4393,7 @@ module BaseBuilt = struct unix_exec_is, unix_dll_opt + let of_library ffn (cs, bs, lib) = let unix_lst = OASISLibrary.generated_unix_files @@ -3674,16 +4413,35 @@ module BaseBuilt = struct in evs, unix_lst + + let of_object ffn (cs, bs, obj) = + let unix_lst = + OASISObject.generated_unix_files + ~ctxt:!BaseContext.default + ~source_file_exists:(fun fn -> + OASISFileUtil.file_exists_case (OASISHostPath.of_unix fn)) + ~is_native:(bool_of_string (is_native ())) + (cs, bs, obj) + in + let evs = + [BObj, + cs.cs_name, + List.map (List.map ffn) unix_lst] + in + evs, unix_lst + end module BaseCustom = struct -(* # 21 "src/base/BaseCustom.ml" *) +(* # 22 "src/base/BaseCustom.ml" *) + open BaseEnv open BaseMessage open OASISTypes open OASISGettext + let run cmd args extra_args = OASISExec.run ~ctxt:!BaseContext.default ~quote:false (var_expand cmd) @@ -3691,6 +4449,7 @@ module BaseCustom = struct var_expand (args @ (Array.to_list extra_args))) + let hook ?(failsafe=false) cstm f e = let optional_command lst = let printer = @@ -3727,7 +4486,7 @@ module BaseCustom = struct end module BaseDynVar = struct -(* # 21 "src/base/BaseDynVar.ml" *) +(* # 22 "src/base/BaseDynVar.ml" *) open OASISTypes @@ -3735,6 +4494,7 @@ module BaseDynVar = struct open BaseEnv open BaseBuilt + let init pkg = (* TODO: disambiguate exec vs other variable by adding exec_VARNAME. *) (* TODO: provide compile option for library libary_byte_args_VARNAME... *) @@ -3768,13 +4528,14 @@ module BaseDynVar = struct (f_ "Executable '%s' not yet built.") cs.cs_name))))) - | Library _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> + | Library _ | Object _ | Flag _ | Test _ | SrcRepo _ | Doc _ -> ()) pkg.sections end module BaseTest = struct -(* # 21 "src/base/BaseTest.ml" *) +(* # 22 "src/base/BaseTest.ml" *) + open BaseEnv open BaseMessage @@ -3782,6 +4543,7 @@ module BaseTest = struct open OASISExpr open OASISGettext + let test lst pkg extra_args = let one_test (failure, n) (test_plugin, cs, test) = @@ -3832,7 +4594,7 @@ module BaseTest = struct (failure, n) end in - let (failed, n) = + let failed, n = List.fold_left one_test (0.0, 0) @@ -3855,7 +4617,7 @@ module BaseTest = struct info "%s" msg; (* Possible explanation why the tests where not run. *) - if OASISVersion.version_0_3_or_after pkg.oasis_version && + if OASISFeatures.package_test OASISFeatures.flag_tests pkg && not (bool_of_string (BaseStandardVar.tests ())) && lst <> [] then BaseMessage.warning @@ -3864,13 +4626,15 @@ module BaseTest = struct end module BaseDoc = struct -(* # 21 "src/base/BaseDoc.ml" *) +(* # 22 "src/base/BaseDoc.ml" *) + open BaseEnv open BaseMessage open OASISTypes open OASISGettext + let doc lst pkg extra_args = let one_doc (doc_plugin, cs, doc) = @@ -3890,7 +4654,7 @@ module BaseDoc = struct in List.iter one_doc lst; - if OASISVersion.version_0_3_or_after pkg.oasis_version && + if OASISFeatures.package_test OASISFeatures.flag_docs pkg && not (bool_of_string (BaseStandardVar.docs ())) && lst <> [] then BaseMessage.warning @@ -3899,7 +4663,7 @@ module BaseDoc = struct end module BaseSetup = struct -(* # 21 "src/base/BaseSetup.ml" *) +(* # 22 "src/base/BaseSetup.ml" *) open BaseEnv open BaseMessage @@ -3908,12 +4672,15 @@ module BaseSetup = struct open OASISGettext open OASISUtils + type std_args_fun = package -> string array -> unit + type ('a, 'b) section_args_fun = name * (package -> (common_section * 'a) -> string array -> 'b) + type t = { configure: std_args_fun; @@ -3937,6 +4704,7 @@ module BaseSetup = struct setup_update: bool; } + (* Associate a plugin function with data from package *) let join_plugin_sections filter_map lst = List.rev @@ -3950,6 +4718,7 @@ module BaseSetup = struct [] lst) + (* Search for plugin data associated with a section name *) let lookup_plugin_section plugin action nm lst = try @@ -3961,11 +4730,12 @@ module BaseSetup = struct nm action + let configure t args = (* Run configure *) BaseCustom.hook t.package.conf_custom - (fun () -> + (fun () -> (* Reload if preconf has changed it *) begin try @@ -3992,12 +4762,14 @@ module BaseSetup = struct (* Replace data in file *) BaseFileAB.replace t.package.files_ab + let build t args = BaseCustom.hook t.package.build_custom (t.build t.package) args + let doc t args = BaseDoc.doc (join_plugin_sections @@ -4017,6 +4789,7 @@ module BaseSetup = struct t.package args + let test t args = BaseTest.test (join_plugin_sections @@ -4036,12 +4809,16 @@ module BaseSetup = struct t.package args + let all t args = let rno_doc = ref false in let rno_test = ref false + in + let arg_rest = + ref [] in Arg.parse_argv ~current:(ref 0) @@ -4056,12 +4833,16 @@ module BaseSetup = struct "-no-test", Arg.Set rno_test, s_ "Don't run test target"; + + "--", + Arg.Rest (fun arg -> arg_rest := arg :: !arg_rest), + s_ "All arguments for configure."; ] (failwithf (f_ "Don't know what to do with '%s'")) ""; info "Running configure step"; - configure t [||]; + configure t (Array.of_list (List.rev !arg_rest)); info "Running build step"; build t [||]; @@ -4089,22 +4870,26 @@ module BaseSetup = struct info "Skipping test step" end + let install t args = BaseCustom.hook t.package.install_custom (t.install t.package) args + let uninstall t args = BaseCustom.hook t.package.uninstall_custom (t.uninstall t.package) args + let reinstall t args = uninstall t args; install t args + let clean, distclean = let failsafe f a = try @@ -4146,6 +4931,7 @@ module BaseSetup = struct (f t.package (cs, doc)) args | Library _ + | Object _ | Executable _ | Flag _ | SrcRepo _ -> @@ -4201,9 +4987,11 @@ module BaseSetup = struct clean, distclean + let version t _ = print_endline t.oasis_version + let update_setup_ml, no_update_setup_ml_cli = let b = ref true in b, @@ -4211,6 +4999,7 @@ module BaseSetup = struct Arg.Clear b, s_ " Don't try to update setup.ml, even if _oasis has changed.") + let update_setup_ml t = let oasis_fn = match t.oasis_fn with @@ -4333,6 +5122,7 @@ module BaseSetup = struct else false + let setup t = let catch_exn = ref true @@ -4474,41 +5264,34 @@ module BaseSetup = struct error "%s" (Printexc.to_string e); exit 1 + end -# 4480 "setup.ml" +# 5271 "setup.ml" module InternalConfigurePlugin = struct -(* # 21 "src/plugins/internal/InternalConfigurePlugin.ml" *) +(* # 22 "src/plugins/internal/InternalConfigurePlugin.ml" *) + (** Configure using internal scheme @author Sylvain Le Gall *) + open BaseEnv open OASISTypes open OASISUtils open OASISGettext open BaseMessage + (** Configure build using provided series of check to be done * and then output corresponding file. *) let configure pkg argv = - let var_ignore_eval var = - let _s : string = - var () - in - () - in - - let errors = - ref SetString.empty - in - - let buff = - Buffer.create 13 - in + let var_ignore_eval var = let _s: string = var () in () in + let errors = ref SetString.empty in + let buff = Buffer.create 13 in let add_errors fmt = Printf.kbprintf @@ -4656,6 +5439,20 @@ module InternalConfigurePlugin = struct | None -> () end; + (* Make sure the findlib version is fine for the OCaml compiler. *) + begin + let ocaml_ge4 = + OASISVersion.version_compare + (OASISVersion.version_of_string (BaseStandardVar.ocaml_version())) + (OASISVersion.version_of_string "4.0.0") >= 0 in + if ocaml_ge4 then + let findlib_lt132 = + OASISVersion.version_compare + (OASISVersion.version_of_string (BaseStandardVar.findlib_version())) + (OASISVersion.version_of_string "1.3.2") < 0 in + if findlib_lt132 then + add_errors "OCaml >= 4.0.0 requires Findlib version >= 1.3.2" + end; (* FlexDLL *) if BaseStandardVar.os_type () = "Win32" || @@ -4718,43 +5515,58 @@ module InternalConfigurePlugin = struct (SetString.cardinal !errors) end + end module InternalInstallPlugin = struct -(* # 21 "src/plugins/internal/InternalInstallPlugin.ml" *) +(* # 22 "src/plugins/internal/InternalInstallPlugin.ml" *) + (** Install using internal scheme @author Sylvain Le Gall *) + open BaseEnv open BaseStandardVar open BaseMessage open OASISTypes - open OASISLibrary + open OASISFindlib open OASISGettext open OASISUtils + let exec_hook = ref (fun (cs, bs, exec) -> cs, bs, exec) + let lib_hook = ref (fun (cs, bs, lib) -> cs, bs, lib, []) + + let obj_hook = + ref (fun (cs, bs, obj) -> cs, bs, obj, []) + + let doc_hook = ref (fun (cs, doc) -> cs, doc) + let install_file_ev = "install-file" + let install_dir_ev = "install-dir" + let install_findlib_ev = "install-findlib" + let win32_max_command_line_length = 8000 + let split_install_command ocamlfind findlib_name meta files = if Sys.os_type = "Win32" then (* Arguments for the first command: *) @@ -4794,20 +5606,21 @@ module InternalInstallPlugin = struct | (firsts, others) -> let cmd = args @ firsts in (* Use -add for remaining commands: *) - let () = + let () = let findlib_ge_132 = OASISVersion.comparator_apply - (OASISVersion.version_of_string + (OASISVersion.version_of_string (BaseStandardVar.findlib_version ())) - (OASISVersion.VGreaterEqual + (OASISVersion.VGreaterEqual (OASISVersion.version_of_string "1.3.2")) in if not findlib_ge_132 then failwithf - (f_ "Installing the library %s require to use the flag \ - '-add' of ocamlfind because the command line is too \ - long. This flag is only available for findlib 1.3.2. \ - Please upgrade findlib from %s to 1.3.2") + (f_ "Installing the library %s require to use the \ + flag '-add' of ocamlfind because the command \ + line is too long. This flag is only available \ + for findlib 1.3.2. Please upgrade findlib from \ + %s to 1.3.2") findlib_name (BaseStandardVar.findlib_version ()) in let cmds = split other_args others in @@ -4818,6 +5631,7 @@ module InternalInstallPlugin = struct else ["install" :: findlib_name :: meta :: files] + let install pkg argv = let in_destdir = @@ -4961,6 +5775,75 @@ module InternalInstallPlugin = struct begin (f_data, acc) end + and files_of_object (f_data, acc) data_obj = + let cs, bs, obj, obj_extra = + !obj_hook data_obj + in + if var_choose bs.bs_install && + BaseBuilt.is_built BaseBuilt.BObj cs.cs_name then + begin + let acc = + (* Start with acc + obj_extra *) + List.rev_append obj_extra acc + in + let acc = + (* Add uncompiled header from the source tree *) + let path = + OASISHostPath.of_unix bs.bs_path + in + List.fold_left + (fun acc modul -> + try + List.find + OASISFileUtil.file_exists_case + (List.map + (Filename.concat path) + [modul^".mli"; + modul^".ml"; + String.uncapitalize modul^".mli"; + String.capitalize modul^".mli"; + String.uncapitalize modul^".ml"; + String.capitalize modul^".ml"]) + :: acc + with Not_found -> + begin + warning + (f_ "Cannot find source header for module %s \ + in object %s") + modul cs.cs_name; + acc + end) + acc + obj.obj_modules + in + + let acc = + (* Get generated files *) + BaseBuilt.fold + BaseBuilt.BObj + cs.cs_name + (fun acc fn -> fn :: acc) + acc + in + + let f_data () = + (* Install data associated with the object *) + install_data + bs.bs_path + bs.bs_data_files + (Filename.concat + (datarootdir ()) + pkg.name); + f_data () + in + + (f_data, acc) + end + else + begin + (f_data, acc) + end + in (* Install one group of library *) @@ -4971,8 +5854,10 @@ module InternalInstallPlugin = struct match grp with | Container (_, children) -> data_and_files, children - | Package (_, cs, bs, lib, children) -> + | Package (_, cs, bs, `Library lib, children) -> files_of_library data_and_files (cs, bs, lib), children + | Package (_, cs, bs, `Object obj, children) -> + files_of_object data_and_files (cs, bs, obj), children in List.fold_left install_group_lib_aux @@ -5006,7 +5891,7 @@ module InternalInstallPlugin = struct begin let meta = (* Search META file *) - let (_, bs, _) = + let _, bs, _ = root_lib in let res = @@ -5019,7 +5904,7 @@ module InternalInstallPlugin = struct findlib_name; res in - let files = + let files = (* Make filename shorter to avoid hitting command max line length * too early, esp. on Windows. *) @@ -5028,24 +5913,24 @@ module InternalInstallPlugin = struct let nlen = String.length n in if plen <= nlen && String.sub n 0 plen = p then begin - let fn_sep = + let fn_sep = if Sys.os_type = "Win32" then '\\' else '/' in let cutpoint = plen + - (if plen < nlen && n.[plen] = fn_sep then + (if plen < nlen && n.[plen] = fn_sep then 1 - else + else 0) in String.sub n cutpoint (nlen - cutpoint) end - else + else n in - List.map (remove_prefix (Sys.getcwd ())) files + List.map (remove_prefix (Sys.getcwd ())) files in info (f_ "Installing findlib library '%s'") @@ -5079,7 +5964,7 @@ module InternalInstallPlugin = struct let install_execs pkg = let install_exec data_exec = - let (cs, bs, exec) = + let cs, bs, exec = !exec_hook data_exec in if var_choose bs.bs_install && @@ -5126,7 +6011,7 @@ module InternalInstallPlugin = struct let install_docs pkg = let install_doc data = - let (cs, doc) = + let cs, doc = !doc_hook data in if var_choose doc.doc_install && @@ -5162,6 +6047,7 @@ module InternalInstallPlugin = struct install_execs pkg; install_docs pkg + (* Uninstall already installed data *) let uninstall _ argv = List.iter @@ -5225,31 +6111,37 @@ module InternalInstallPlugin = struct (BaseLog.filter [install_file_ev; install_dir_ev; - install_findlib_ev;])) + install_findlib_ev])) + end -# 5233 "setup.ml" +# 6120 "setup.ml" module OCamlbuildCommon = struct -(* # 21 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) +(* # 22 "src/plugins/ocamlbuild/OCamlbuildCommon.ml" *) + (** Functions common to OCamlbuild build and doc plugin *) + open OASISGettext open BaseEnv open BaseStandardVar + let ocamlbuild_clean_ev = "ocamlbuild-clean" + let ocamlbuildflags = var_define ~short_desc:(fun () -> "OCamlbuild additional flags") "ocamlbuildflags" (fun () -> "") + (** Fix special arguments depending on environment *) let fix_args args extra_argv = List.flatten @@ -5288,6 +6180,7 @@ module OCamlbuildCommon = struct Array.to_list extra_argv; ] + (** Run 'ocamlbuild -clean' if not already done *) let run_clean extra_argv = let extra_cli = @@ -5307,6 +6200,7 @@ module OCamlbuildCommon = struct ()) end + (** Run ocamlbuild, unregister all clean events *) let run_ocamlbuild args extra_argv = (* TODO: enforce that target in args must be UNIX encoded i.e. toto/index.html @@ -5318,6 +6212,7 @@ module OCamlbuildCommon = struct (fun (e, d) -> BaseLog.unregister e d) (BaseLog.filter [ocamlbuild_clean_ev]) + (** Determine real build directory *) let build_dir extra_argv = let rec search_args dir = @@ -5331,28 +6226,56 @@ module OCamlbuildCommon = struct in search_args "_build" (fix_args [] extra_argv) + end module OCamlbuildPlugin = struct -(* # 21 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) +(* # 22 "src/plugins/ocamlbuild/OCamlbuildPlugin.ml" *) + (** Build using ocamlbuild @author Sylvain Le Gall *) + open OASISTypes open OASISGettext open OASISUtils + open OASISString open BaseEnv open OCamlbuildCommon open BaseStandardVar open BaseMessage + + + + let cond_targets_hook = ref (fun lst -> lst) - let build pkg argv = + type ocamlbuild_plugin = + { + plugin_tags: string option; + extra_args: string list; + } + + + let check_ocaml_version version pkg = + match pkg.ocaml_version with + | Some ocaml_version -> + let min_ocaml_version = OASISVersion.version_of_string version in + OASISVersion.comparator_ge min_ocaml_version ocaml_version + | None -> + false + + + let ocamlbuild_supports_ocamlfind = check_ocaml_version "3.12.1" + let ocamlbuild_supports_plugin_tags = check_ocaml_version "4.01" + + + let build t pkg argv = (* Return the filename in build directory *) let in_build_dir fn = Filename.concat @@ -5377,16 +6300,36 @@ module OCamlbuildPlugin = struct (cs, bs, lib) in - let ends_with nd fn = - let nd_len = - String.length nd - in - (String.length fn >= nd_len) - && - (String.sub - fn - (String.length fn - nd_len) - nd_len) = nd + let tgts = + List.flatten + (List.filter + (fun l -> l <> []) + (List.map + (List.filter + (fun fn -> + ends_with ~what:".cma" fn + || ends_with ~what:".cmxs" fn + || ends_with ~what:".cmxa" fn + || ends_with ~what:(ext_lib ()) fn + || ends_with ~what:(ext_dll ()) fn)) + unix_files)) + in + + match tgts with + | _ :: _ -> + (evs, tgts) :: acc + | [] -> + failwithf + (f_ "No possible ocamlbuild targets for library %s") + cs.cs_name + end + + | Object (cs, bs, obj) when var_choose bs.bs_build -> + begin + let evs, unix_files = + BaseBuilt.of_object + in_build_dir_of_unix + (cs, bs, obj) in let tgts = @@ -5396,11 +6339,8 @@ module OCamlbuildPlugin = struct (List.map (List.filter (fun fn -> - ends_with ".cma" fn - || ends_with ".cmxs" fn - || ends_with ".cmxa" fn - || ends_with (ext_lib ()) fn - || ends_with (ext_dll ()) fn)) + ends_with ".cmo" fn + || ends_with ".cmx" fn)) unix_files)) in @@ -5409,7 +6349,7 @@ module OCamlbuildPlugin = struct (evs, tgts) :: acc | [] -> failwithf - (f_ "No possible ocamlbuild targets for library %s") + (f_ "No possible ocamlbuild targets for object %s") cs.cs_name end @@ -5428,12 +6368,13 @@ module OCamlbuildPlugin = struct (OASISUnixPath.chop_extension exec.exec_main_is))^ext in - let evs = + let evs = (* Fix evs, we want to use the unix_tgt, without copying *) List.map (function | BaseBuilt.BExec, nm, lst when nm = cs.cs_name -> - BaseBuilt.BExec, nm, [[in_build_dir_of_unix unix_tgt]] + BaseBuilt.BExec, nm, + [[in_build_dir_of_unix unix_tgt]] | ev -> ev) evs @@ -5455,7 +6396,7 @@ module OCamlbuildPlugin = struct acc end - | Library _ | Executable _ | Test _ + | Library _ | Object _ | Executable _ | Test _ | SrcRepo _ | Flag _ | Doc _ -> acc) [] @@ -5469,8 +6410,11 @@ module OCamlbuildPlugin = struct (fun fns -> if not (List.exists OASISFileUtil.file_exists_case fns) then failwithf - (f_ "No one of expected built files %s exists") - (String.concat (s_ ", ") (List.map (Printf.sprintf "'%s'") fns))) + (fn_ + "Expected built file %s doesn't exist." + "None of expected built files %s exists." + (List.length fns)) + (String.concat (s_ " or ") (List.map (Printf.sprintf "'%s'") fns))) lst; (BaseBuilt.register bt bnm lst) in @@ -5480,10 +6424,23 @@ module OCamlbuildPlugin = struct !cond_targets_hook cond_targets in + let extra_args = + match t.plugin_tags with + | Some tags -> "-plugin-tags" :: ("'" ^ tags ^ "'") :: t.extra_args + | None -> t.extra_args + in + let extra_args = + if ocamlbuild_supports_ocamlfind pkg then + "-use-ocamlfind" :: extra_args + else + extra_args + in + (* Run a list of target... *) - run_ocamlbuild - (List.flatten - (List.map snd cond_targets)) + run_ocamlbuild + (List.flatten + (List.map snd cond_targets) + @ extra_args) argv; (* ... and register events *) List.iter @@ -5504,15 +6461,18 @@ module OCamlbuildPlugin = struct ()) pkg.sections + end module OCamlbuildDocPlugin = struct -(* # 21 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) +(* # 22 "src/plugins/ocamlbuild/OCamlbuildDocPlugin.ml" *) + (* Create documentation using ocamlbuild .odocl files @author Sylvain Le Gall *) + open OASISTypes open OASISGettext open OASISMessage @@ -5521,6 +6481,8 @@ module OCamlbuildDocPlugin = struct + + let doc_build path pkg (cs, doc) argv = let index_html = OASISUnixPath.make @@ -5548,27 +6510,33 @@ module OCamlbuildDocPlugin = struct (Filename.concat tgt_dir glb)]) ["*.html"; "*.css"] + let doc_clean t pkg (cs, doc) argv = run_clean argv; BaseBuilt.unregister BaseBuilt.BDoc cs.cs_name + end -# 5558 "setup.ml" +# 6522 "setup.ml" module CustomPlugin = struct -(* # 21 "src/plugins/custom/CustomPlugin.ml" *) +(* # 22 "src/plugins/custom/CustomPlugin.ml" *) + (** Generate custom configure/build/doc/test/install system @author *) + open BaseEnv open OASISGettext open OASISTypes + + type t = { cmd_main: command_line conditional; @@ -5576,15 +6544,18 @@ module CustomPlugin = struct cmd_distclean: (command_line option) conditional; } - let run = BaseCustom.run + + let run = BaseCustom.run + let main t _ extra_args = let cmd, args = - var_choose - ~name:(s_ "main command") + var_choose + ~name:(s_ "main command") t.cmd_main in - run cmd args extra_args + run cmd args extra_args + let clean t pkg extra_args = match var_choose t.cmd_clean with @@ -5593,6 +6564,7 @@ module CustomPlugin = struct | _ -> () + let distclean t pkg extra_args = match var_choose t.cmd_distclean with | Some (cmd, args) -> @@ -5600,20 +6572,21 @@ module CustomPlugin = struct | _ -> () + module Build = - struct + struct let main t pkg extra_args = main t pkg extra_args; List.iter (fun sct -> let evs = - match sct with + match sct with | Library (cs, bs, lib) when var_choose bs.bs_build -> begin - let evs, _ = - BaseBuilt.of_library + let evs, _ = + BaseBuilt.of_library OASISHostPath.of_unix - (cs, bs, lib) + (cs, bs, lib) in evs end @@ -5654,6 +6627,7 @@ module CustomPlugin = struct distclean t pkg extra_args end + module Test = struct let main t pkg (cs, test) extra_args = @@ -5661,7 +6635,7 @@ module CustomPlugin = struct main t pkg extra_args; 0.0 with Failure s -> - BaseMessage.warning + BaseMessage.warning (f_ "Test '%s' fails: %s") cs.cs_name s; @@ -5671,9 +6645,10 @@ module CustomPlugin = struct clean t pkg extra_args let distclean t pkg (cs, test) extra_args = - distclean t pkg extra_args + distclean t pkg extra_args end + module Doc = struct let main t pkg (cs, _) extra_args = @@ -5688,16 +6663,19 @@ module CustomPlugin = struct distclean t pkg extra_args end + end -# 5694 "setup.ml" +# 6670 "setup.ml" open OASISTypes;; let setup_t = { BaseSetup.configure = InternalConfigurePlugin.configure; - build = OCamlbuildPlugin.build; + build = + OCamlbuildPlugin.build + {OCamlbuildPlugin.plugin_tags = None; extra_args = []}; test = [ ("test_accept", @@ -5706,40 +6684,40 @@ let setup_t = CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_accept", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }); + cmd_distclean = [(OASISExpr.EBool true, None)] + }); ("test_header", CustomPlugin.Test.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_header", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }); + cmd_distclean = [(OASISExpr.EBool true, None)] + }); ("test_parser", CustomPlugin.Test.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_parser", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }); + cmd_distclean = [(OASISExpr.EBool true, None)] + }); ("test_net_lwt", CustomPlugin.Test.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_net_lwt", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }); + cmd_distclean = [(OASISExpr.EBool true, None)] + }); ("test_net_async", CustomPlugin.Test.main { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_net_async", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }) + cmd_distclean = [(OASISExpr.EBool true, None)] + }) ]; doc = [ @@ -5760,40 +6738,40 @@ let setup_t = CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_accept", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }); + cmd_distclean = [(OASISExpr.EBool true, None)] + }); ("test_header", CustomPlugin.Test.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_header", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }); + cmd_distclean = [(OASISExpr.EBool true, None)] + }); ("test_parser", CustomPlugin.Test.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_parser", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }); + cmd_distclean = [(OASISExpr.EBool true, None)] + }); ("test_net_lwt", CustomPlugin.Test.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_net_lwt", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }); + cmd_distclean = [(OASISExpr.EBool true, None)] + }); ("test_net_async", CustomPlugin.Test.clean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_net_async", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }) + cmd_distclean = [(OASISExpr.EBool true, None)] + }) ]; clean_doc = [ @@ -5812,40 +6790,40 @@ let setup_t = CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_accept", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }); + cmd_distclean = [(OASISExpr.EBool true, None)] + }); ("test_header", CustomPlugin.Test.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_header", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }); + cmd_distclean = [(OASISExpr.EBool true, None)] + }); ("test_parser", CustomPlugin.Test.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_parser", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }); + cmd_distclean = [(OASISExpr.EBool true, None)] + }); ("test_net_lwt", CustomPlugin.Test.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_net_lwt", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }); + cmd_distclean = [(OASISExpr.EBool true, None)] + }); ("test_net_async", CustomPlugin.Test.distclean { CustomPlugin.cmd_main = [(OASISExpr.EBool true, ("$test_net_async", []))]; cmd_clean = [(OASISExpr.EBool true, None)]; - cmd_distclean = [(OASISExpr.EBool true, None)]; - }) + cmd_distclean = [(OASISExpr.EBool true, None)] + }) ]; distclean_doc = []; package = @@ -5853,16 +6831,18 @@ let setup_t = oasis_version = "0.3"; ocaml_version = None; findlib_version = None; + alpha_features = []; + beta_features = []; name = "cohttp"; - version = "0.9.13"; + version = "0.9.14"; license = OASISLicense.DEP5License (OASISLicense.DEP5Unit { - OASISLicense.license = "LGPL"; - excption = Some "OCaml linking"; - version = OASISLicense.Version "2.0"; - }); + OASISLicense.license = "ISC"; + excption = None; + version = OASISLicense.NoVersion + }); license_file = None; copyrights = []; maintainers = []; @@ -5878,39 +6858,39 @@ let setup_t = synopsis = "HTTP library for Lwt, Async and Mirage"; description = None; categories = []; - conf_type = (`Configure, "internal", Some "0.3"); + conf_type = (`Configure, "internal", Some "0.4"); conf_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - build_type = (`Build, "ocamlbuild", Some "0.3"); + post_command = [(OASISExpr.EBool true, None)] + }; + build_type = (`Build, "ocamlbuild", Some "0.4"); build_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; - install_type = (`Install, "internal", Some "0.3"); + post_command = [(OASISExpr.EBool true, None)] + }; + install_type = (`Install, "internal", Some "0.4"); install_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; + post_command = [(OASISExpr.EBool true, None)] + }; uninstall_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; + post_command = [(OASISExpr.EBool true, None)] + }; clean_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; + post_command = [(OASISExpr.EBool true, None)] + }; distclean_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; + post_command = [(OASISExpr.EBool true, None)] + }; files_ab = []; sections = [ @@ -5918,8 +6898,8 @@ let setup_t = ({ cs_name = "cohttp"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { bs_build = [(OASISExpr.EBool true, true)]; bs_install = [(OASISExpr.EBool true, true)]; @@ -5943,8 +6923,8 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, { lib_modules = [ @@ -5970,66 +6950,66 @@ let setup_t = lib_internal_modules = []; lib_findlib_parent = None; lib_findlib_name = Some "cohttp"; - lib_findlib_containers = []; - }); + lib_findlib_containers = [] + }); Flag ({ cs_name = "lwt"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { flag_description = Some "build the Lwt library"; - flag_default = [(OASISExpr.EBool true, false)]; - }); + flag_default = [(OASISExpr.EBool true, false)] + }); Flag ({ cs_name = "async"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { flag_description = Some "build the Core/Async library"; - flag_default = [(OASISExpr.EBool true, false)]; - }); + flag_default = [(OASISExpr.EBool true, false)] + }); Flag ({ cs_name = "mirage_unix"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { flag_description = Some "build the Mirage library for Unix"; - flag_default = [(OASISExpr.EBool true, false)]; - }); + flag_default = [(OASISExpr.EBool true, false)] + }); Flag ({ cs_name = "mirage_xen"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { flag_description = Some "build the Mirage library for Xen"; - flag_default = [(OASISExpr.EBool true, false)]; - }); + flag_default = [(OASISExpr.EBool true, false)] + }); Flag ({ cs_name = "nettests"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { flag_description = Some "run the internet-using tests"; - flag_default = [(OASISExpr.EBool true, false)]; - }); + flag_default = [(OASISExpr.EBool true, false)] + }); Library ({ cs_name = "cohttp_lwt"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { bs_build = [ @@ -6068,22 +7048,22 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, { lib_modules = ["Cohttp_lwt_body"; "Cohttp_lwt"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "cohttp"; lib_findlib_name = Some "lwt-core"; - lib_findlib_containers = []; - }); + lib_findlib_containers = [] + }); Library ({ cs_name = "cohttp_lwt_unix"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { bs_build = [ @@ -6112,8 +7092,8 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, { lib_modules = [ @@ -6125,14 +7105,14 @@ let setup_t = lib_internal_modules = []; lib_findlib_parent = Some "cohttp"; lib_findlib_name = Some "lwt"; - lib_findlib_containers = []; - }); + lib_findlib_containers = [] + }); Library ({ cs_name = "cohttp_mirage_unix"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { bs_build = [ @@ -6161,22 +7141,22 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, { lib_modules = ["Cohttp_mirage_io"; "Cohttp_mirage"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "cohttp"; lib_findlib_name = Some "mirage-unix"; - lib_findlib_containers = []; - }); + lib_findlib_containers = [] + }); Library ({ cs_name = "cohttp_mirage_xen"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { bs_build = [ @@ -6205,22 +7185,22 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, { lib_modules = ["Cohttp_mirage_io"; "Cohttp_mirage"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "cohttp"; lib_findlib_name = Some "mirage-xen"; - lib_findlib_containers = []; - }); + lib_findlib_containers = [] + }); Library ({ cs_name = "cohttp_async"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { bs_build = [ @@ -6253,29 +7233,29 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, { lib_modules = ["Cohttp_async"]; lib_pack = false; lib_internal_modules = []; lib_findlib_parent = Some "cohttp"; lib_findlib_name = Some "async"; - lib_findlib_containers = []; - }); + lib_findlib_containers = [] + }); Doc ({ cs_name = "cohttp"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { doc_type = (`Doc, "ocamlbuild", Some "0.3"); doc_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; + post_command = [(OASISExpr.EBool true, None)] + }; doc_build = [ (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); @@ -6289,21 +7269,21 @@ let setup_t = doc_format = OtherDoc; doc_data_files = []; doc_build_tools = - [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"]; - }); + [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] + }); Doc ({ cs_name = "cohttp_lwt_unix"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { doc_type = (`Doc, "ocamlbuild", Some "0.3"); doc_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; + post_command = [(OASISExpr.EBool true, None)] + }; doc_build = [ (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); @@ -6320,21 +7300,21 @@ let setup_t = doc_format = OtherDoc; doc_data_files = []; doc_build_tools = - [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"]; - }); + [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] + }); Doc ({ cs_name = "cohttp_async"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { doc_type = (`Doc, "ocamlbuild", Some "0.3"); doc_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; + post_command = [(OASISExpr.EBool true, None)] + }; doc_build = [ (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); @@ -6352,21 +7332,21 @@ let setup_t = doc_format = OtherDoc; doc_data_files = []; doc_build_tools = - [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"]; - }); + [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] + }); Doc ({ cs_name = "cohttp_mirage_unix"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { doc_type = (`Doc, "ocamlbuild", Some "0.3"); doc_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; + post_command = [(OASISExpr.EBool true, None)] + }; doc_build = [ (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); @@ -6384,21 +7364,21 @@ let setup_t = doc_format = OtherDoc; doc_data_files = []; doc_build_tools = - [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"]; - }); + [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] + }); Doc ({ cs_name = "cohttp_mirage_xen"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { doc_type = (`Doc, "ocamlbuild", Some "0.3"); doc_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; + post_command = [(OASISExpr.EBool true, None)] + }; doc_build = [ (OASISExpr.ENot (OASISExpr.EFlag "docs"), false); @@ -6416,14 +7396,14 @@ let setup_t = doc_format = OtherDoc; doc_data_files = []; doc_build_tools = - [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"]; - }); + [ExternalTool "ocamlbuild"; ExternalTool "ocamldoc"] + }); Executable ({ cs_name = "test_parser"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { bs_build = [ @@ -6452,15 +7432,15 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - {exec_custom = true; exec_main_is = "test_parser.ml"; }); + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + {exec_custom = true; exec_main_is = "test_parser.ml"}); Executable ({ cs_name = "test_accept"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { bs_build = [ @@ -6485,15 +7465,15 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - {exec_custom = true; exec_main_is = "test_accept.ml"; }); + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + {exec_custom = true; exec_main_is = "test_accept.ml"}); Executable ({ cs_name = "test_header"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { bs_build = [ @@ -6518,15 +7498,15 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - {exec_custom = true; exec_main_is = "test_header.ml"; }); + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + {exec_custom = true; exec_main_is = "test_header.ml"}); Executable ({ cs_name = "test_net_lwt"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { bs_build = [ @@ -6555,15 +7535,15 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - {exec_custom = true; exec_main_is = "test_net_lwt.ml"; }); + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + {exec_custom = true; exec_main_is = "test_net_lwt.ml"}); Executable ({ cs_name = "test_net_lwt_google"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { bs_build = [ @@ -6585,18 +7565,18 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, { exec_custom = true; - exec_main_is = "test_net_lwt_google.ml"; - }); + exec_main_is = "test_net_lwt_google.ml" + }); Executable ({ cs_name = "test_net_lwt_lastminute"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { bs_build = [ @@ -6618,18 +7598,18 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, { exec_custom = true; - exec_main_is = "test_net_lwt_lastminute.ml"; - }); + exec_main_is = "test_net_lwt_lastminute.ml" + }); Executable ({ cs_name = "test_net_lwt_server"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { bs_build = [ @@ -6655,18 +7635,18 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, { exec_custom = true; - exec_main_is = "test_net_lwt_server.ml"; - }); + exec_main_is = "test_net_lwt_server.ml" + }); Executable ({ cs_name = "test_net_lwt_multi_get"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { bs_build = [ @@ -6692,18 +7672,18 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, { exec_custom = true; - exec_main_is = "test_net_lwt_multi_get.ml"; - }); + exec_main_is = "test_net_lwt_multi_get.ml" + }); Executable ({ cs_name = "test_net_lwt_client_and_server"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { bs_build = [ @@ -6729,18 +7709,18 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, { exec_custom = true; - exec_main_is = "test_net_lwt_client_and_server.ml"; - }); + exec_main_is = "test_net_lwt_client_and_server.ml" + }); Executable ({ cs_name = "test_net_async"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { bs_build = [ @@ -6769,15 +7749,15 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, - {exec_custom = true; exec_main_is = "test_net_async.ml"; }); + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + {exec_custom = true; exec_main_is = "test_net_async.ml"}); Executable ({ cs_name = "test_net_async_http10"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { bs_build = [ @@ -6806,18 +7786,18 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, { exec_custom = true; - exec_main_is = "test_net_async_http10.ml"; - }); + exec_main_is = "test_net_async_http10.ml" + }); Executable ({ cs_name = "test_net_async_multi_get"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { bs_build = [ @@ -6846,18 +7826,18 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, { exec_custom = true; - exec_main_is = "test_net_async_multi_get.ml"; - }); + exec_main_is = "test_net_async_multi_get.ml" + }); Executable ({ cs_name = "test_net_async_server"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { bs_build = [ @@ -6886,27 +7866,64 @@ let setup_t = bs_dlllib = [(OASISExpr.EBool true, [])]; bs_dllpath = [(OASISExpr.EBool true, [])]; bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])]; - }, + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, + { + exec_custom = true; + exec_main_is = "test_net_async_server.ml" + }); + Executable + ({ + cs_name = "cohttp-server"; + cs_data = PropList.Data.create (); + cs_plugin_data = [] + }, + { + bs_build = + [ + (OASISExpr.EBool true, false); + (OASISExpr.EAnd + (OASISExpr.EFlag "tests", + OASISExpr.EFlag "async"), + true) + ]; + bs_install = [(OASISExpr.EBool true, true)]; + bs_path = "bin"; + bs_compiled_object = Best; + bs_build_depends = + [ + InternalLibrary "cohttp"; + InternalLibrary "cohttp_async" + ]; + bs_build_tools = [ExternalTool "ocamlbuild"]; + bs_c_sources = []; + bs_data_files = []; + bs_ccopt = [(OASISExpr.EBool true, [])]; + bs_cclib = [(OASISExpr.EBool true, [])]; + bs_dlllib = [(OASISExpr.EBool true, [])]; + bs_dllpath = [(OASISExpr.EBool true, [])]; + bs_byteopt = [(OASISExpr.EBool true, [])]; + bs_nativeopt = [(OASISExpr.EBool true, [])] + }, { exec_custom = true; - exec_main_is = "test_net_async_server.ml"; - }); + exec_main_is = "cohttp_server_async.ml" + }); Test ({ cs_name = "test_accept"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { - test_type = (`Test, "custom", Some "0.3"); + test_type = (`Test, "custom", Some "0.4"); test_command = [(OASISExpr.EBool true, ("$test_accept", []))]; test_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; + post_command = [(OASISExpr.EBool true, None)] + }; test_working_directory = Some "lib_test"; test_run = [ @@ -6917,23 +7934,23 @@ let setup_t = OASISExpr.EFlag "tests"), true) ]; - test_tools = [ExternalTool "ocamlbuild"]; - }); + test_tools = [ExternalTool "ocamlbuild"] + }); Test ({ cs_name = "test_header"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { - test_type = (`Test, "custom", Some "0.3"); + test_type = (`Test, "custom", Some "0.4"); test_command = [(OASISExpr.EBool true, ("$test_header", []))]; test_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; + post_command = [(OASISExpr.EBool true, None)] + }; test_working_directory = Some "lib_test"; test_run = [ @@ -6944,23 +7961,23 @@ let setup_t = OASISExpr.EFlag "tests"), true) ]; - test_tools = [ExternalTool "ocamlbuild"]; - }); + test_tools = [ExternalTool "ocamlbuild"] + }); Test ({ cs_name = "test_parser"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { - test_type = (`Test, "custom", Some "0.3"); + test_type = (`Test, "custom", Some "0.4"); test_command = [(OASISExpr.EBool true, ("$test_parser", []))]; test_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; + post_command = [(OASISExpr.EBool true, None)] + }; test_working_directory = Some "lib_test"; test_run = [ @@ -6973,23 +7990,23 @@ let setup_t = OASISExpr.EFlag "lwt")), true) ]; - test_tools = [ExternalTool "ocamlbuild"]; - }); + test_tools = [ExternalTool "ocamlbuild"] + }); Test ({ cs_name = "test_net_lwt"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { - test_type = (`Test, "custom", Some "0.3"); + test_type = (`Test, "custom", Some "0.4"); test_command = [(OASISExpr.EBool true, ("$test_net_lwt", []))]; test_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; + post_command = [(OASISExpr.EBool true, None)] + }; test_working_directory = Some "lib_test"; test_run = [ @@ -7002,23 +8019,23 @@ let setup_t = OASISExpr.EFlag "lwt")), true) ]; - test_tools = [ExternalTool "ocamlbuild"]; - }); + test_tools = [ExternalTool "ocamlbuild"] + }); Test ({ cs_name = "test_net_async"; cs_data = PropList.Data.create (); - cs_plugin_data = []; - }, + cs_plugin_data = [] + }, { - test_type = (`Test, "custom", Some "0.3"); + test_type = (`Test, "custom", Some "0.4"); test_command = [(OASISExpr.EBool true, ("$test_net_async", []))]; test_custom = { pre_command = [(OASISExpr.EBool true, None)]; - post_command = [(OASISExpr.EBool true, None)]; - }; + post_command = [(OASISExpr.EBool true, None)] + }; test_working_directory = Some "lib_test"; test_run = [ @@ -7031,23 +8048,23 @@ let setup_t = OASISExpr.EFlag "async")), true) ]; - test_tools = [ExternalTool "ocamlbuild"]; - }) + test_tools = [ExternalTool "ocamlbuild"] + }) ]; plugins = [(`Extra, "META", Some "0.3")]; schema_data = PropList.Data.create (); - plugin_data = []; - }; + plugin_data = [] + }; oasis_fn = Some "_oasis"; - oasis_version = "0.3.0"; - oasis_digest = Some "-\022OÌ\011\149\145G\028Ý\n>f\1320\132"; + oasis_version = "0.4.0"; + oasis_digest = Some "\nÄ&\131|à}\005}é\144\007\0209\028["; oasis_exec = None; oasis_setup_args = []; - setup_update = false; - };; + setup_update = false + };; let setup () = BaseSetup.setup setup_t;; -# 7052 "setup.ml" +# 8069 "setup.ml" (* OASIS_STOP *) let () = setup ();;