Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Cleaning up Ohm

  • Loading branch information...
commit ea5b5d0fe132ce62ff6ffe0a727305ae22506381 1 parent b3b299e
Victor Nicollet authored
456 src/action.ml
View
@@ -1,355 +1,143 @@
-(* Ohm is © 2011 Victor Nicollet *)
+(* Ohm is © 2012 Victor Nicollet *)
open Util
open BatPervasives
-module BS = BatString
-module type CONFIG = sig
- type server
- val name_of_server : server -> string
- val server_of_name : string -> server
- val server_suffix : server -> string option
-end
-
-(* ----------------------------------------------------------------- *)
-
-module SingleServer = struct
- type server = [ `TheServer ]
- let name_of_server _ = "*"
- let server_of_name _ = `TheServer
- let server_suffix _ = None
-end
-
-(* ----------------------------------------------------------------- *)
-
-let path_clean path =
- if BS.is_empty path then path
- else let path =
- if BS.ends_with path "/" then BS.rchop path
- else path
- in if BS.starts_with path "/" then BS.lchop path
- else path
-
-(* ----------------------------------------------------------------- *)
-
-module type CUSTOMIZABLE = sig
-
- type response
+open Action_Common
- val html : (View.Context.text View.t -> View.Context.text View.t) -> response -> response
- val page : string -> response -> response
- val redirect : string -> response -> response
- val json : (string * Json_type.t) list -> response -> response
- val with_cookie : name:string -> value:string -> life:int -> response -> response
- val file : file:string -> mime:string -> data:string -> response -> response
- val javascript : JsCode.t -> response -> response
- val more_javascript : JsCode.t -> response -> response
-
- class type request =
- object
- method path : string
- method servername : string
- method format : [ `JSON | `URLENCODED ]
- method post : string -> string option
- method postlist : (string * string) list
- method json : Json_type.t
- method args : int -> string option
- method cookie : string -> string option
- method query : string
- method ip : string
-
- end
-
- type t = request -> response -> (unit,response) Run.t
-
- type server
-
- type controller = server * string
-
- exception Action_not_found of string
-
- val action_of_path : server -> string -> (t * string list) option
- val dispatch : #Netcgi.cgi -> unit
- val register : controller -> t -> unit
- val run : (Netcgi_fcgi.cgi -> unit) -> unit
-end
+include Action_Server
+include Action_Response
+include Action_Request
+include Action_Endpoint
+
+type ('server,'args) controller = 'server server * string * 'args Args.t
-module Customize = functor (Config:CONFIG) -> struct
+type ('server,'args) t = ('server,'args) request -> response -> (unit,response) Run.t
- type response_kind =
- | Page of string
- | Html of (View.Context.text View.t -> View.Context.text View.t) * JsCode.t
- | Redirect of string
- | Json of (string * Json_type.t) list * JsCode.t
- | File of string * string * string
-
- type response =
- {
- kind : response_kind ;
- cookies : (string * string * int) list
- }
-
- let redirect url response = {
- response with
- kind = Redirect url
- }
-
- let more_javascript new_js response = {
- response with
- kind = begin match response.kind with
- | Html (f,js) -> Html (f, JsCode.seq [js;new_js])
- | Json (j,js) -> Json (j, JsCode.seq [js;new_js])
- | keep -> keep
- end
- }
-
- let javascript new_js response = {
- response with
- kind = begin match response.kind with
- | Html (f,js) -> Html (f, JsCode.seq [js;new_js])
- | Json (j,js) -> Json (j, JsCode.seq [js;new_js])
- | _ -> Json ([], new_js)
- end
- }
-
- let with_cookie ~name ~value ~life response = {
- response with
- cookies = (name, value, life) :: response.cookies
- }
+let declared = ref []
+let defined = Hashtbl.create 100
- let page html response = {
- response with
- kind = Page html
- }
-
- let file ~file ~mime ~data response = {
- response with
- kind = File (file, mime, data)
- }
-
- let json json response = {
- response with
- kind = begin match response.kind with
- | Html (_,js) -> Json (json, js)
- | Json (f,js) -> Json (json @ f, js)
- | _ -> Json (json, JsCode.seq [])
- end
- }
-
- let html view response = {
- response with
- kind = begin match response.kind with
- | Html (_,js)
- | Json (_,js) -> Html (view, js)
- | _ -> Html (view, JsCode.seq [])
- end
- }
+let dispatch_define (server,prefix,args) action =
+ if Util.role = `Web then begin
-(* ----------------------------------------------------------------- *)
+ let key = path_clean (lowercase prefix) in
- class type request =
- object
- method path : string
- method format : [`JSON|`URLENCODED]
- method json : Json_type.t
- method servername : string
- method post : string -> string option
- method postlist : (string * string) list
- method args : int -> string option
- method cookie : string -> string option
- method query : string
- method ip : string
- end
-
- class fcgi_request (args : string list) (cgi : Netcgi.cgi) =
- let env = cgi # environment in
- let format =
- if BatString.starts_with (env # input_content_type_string) "application/json"
- then `JSON
- else `URLENCODED
- in
- let path = env # cgi_script_name in
- let json =
- lazy (
- try
- let field = (cgi # argument "BODY") # value in
- match utf8 field with
- | Some field -> Json_io.json_of_string ~recursive:true field
- | None -> Json_type.Null
- with _ -> Json_type.Null
- )
+ let value protocol domain port suffix cgi =
+ match Args.parse args suffix with None -> None | Some args ->
+ match server # matches protocol domain port with None -> None | Some s ->
+ Some (server # cookie_domain, action (new fcgi_request s args cgi))
in
- object
- val path = path_clean path
- val servername = env # cgi_server_name
-
- method args n =
- try
- let arg = BatList.at args n in
- utf8 arg
- with Invalid_argument _ -> None
-
- method path = path
-
- method servername = servername
-
- method format = ( format : [`JSON|`URLENCODED] )
- method json =
- if format = `JSON then
- Lazy.force json
- else
- Json_type.Null
-
- method post field =
- if format = `URLENCODED then
- try
- let field = ((cgi # argument field ) # value) in
- utf8 field
- with Not_found -> None
- else
- None
-
- method ip = env # cgi_remote_addr
-
- method query =
- env # cgi_property ~default:"" "QUERY_STRING"
-
- method postlist =
- if format = `URLENCODED then
- BatList.filter_map begin fun arg ->
- try
- match utf8 (arg # name), utf8 (arg # value) with
- | Some name, Some value -> Some (name,value)
- | _ -> None
- with _ -> None
- end (cgi # arguments)
- else
- []
-
- method cookie name =
- try
- let cookie = env # cookie name in
- let value = Netcgi.Cookie.value cookie in
- utf8 value
- with Not_found -> None
+ Hashtbl.add defined key value
end
- let empty = { kind = Json ( [] , JsCode.seq [] ) ; cookies = [] }
-
- type server = Config.server
- type controller = server * string
- type t = request -> response -> (unit,response) Run.t
-
-
- let _path_hash = Hashtbl.create 100
-
- let _servername = Config.name_of_server
-
- let register (server,path) action =
- if Util.role = `Web then begin
- let path = lowercase path in
- log "Action.register: http://%s/%s" (_servername server) path ;
- Hashtbl.add _path_hash (server,path) action
- end
-
-(* ----------------------------------------------------------------- *)
-
- let (>>) x f = f x
-
- let add_code js json =
- try let code = List.assoc "code" json in
- let js' = match code with Json_type.Array l -> l | _ -> [] in
- let js'' = match js with Json_type.Array l -> l | _ -> [] in
- ("code", Json_type.Array (js' @ js'')) :: json
- with Not_found -> ("code", js) :: json
-
- let _process server (cgi : Netcgi.cgi) response =
-
- let cookies =
- List.map (fun (name,value,age) ->
- let age = if age = 0 then None else Some age in
- Netcgi.Cookie.make ?max_age:age ?domain:(Config.server_suffix server) ~path:"/" name value
- ) response.cookies
- in
-
- let out_channel = (cgi # environment # out_channel :> Netchannels.rec_out_channel) in
+let dispatch_declare (server,prefix,args) =
+ let cell = ref (Some (path_clean (lowercase prefix))) in
+ declared := cell :: !declared ;
+ cell
+
+let ensure () =
+ if !declared <> [] then begin
+ List.iter (fun cell ->
+ match !cell with
+ | None -> ()
+ | Some key -> Util.log "Action: FAIL : action %S declared but not defined" key
+ ) !declared ;
+ declared := [] ;
+ end
- begin match response.kind with
+let declare controller =
+ let cell = dispatch_declare controller and endpoint = endpoint_of_controller controller in
+ endpoint, fun action ->
+ (match !cell with None -> ()
+ | Some key -> Util.log "Action: FAIL : action %S defined twice" key) ;
+ cell := None ;
+ dispatch_define controller action
+
+let register (controller: ('a,'b) controller) action =
+ dispatch_define controller action ;
+ endpoint_of_controller controller
- | Html (write,js) ->
- if cookies <> [] then cgi # set_header ~set_cookies:cookies () ;
- cgi # environment # send_output_header () ;
- ignore (write (JsBase.to_js js) (new View.channel_writer out_channel))
-
- | Page html ->
- if cookies <> [] then cgi # set_header ~set_cookies:cookies () ;
- cgi # environment # send_output_header () ;
- ignore (out_channel # output html 0 (String.length html))
-
- | Redirect url ->
- cgi # set_redirection_header ~set_cookies:cookies url ;
- cgi # environment # send_output_header ()
-
- | File (file, mime, data) ->
- cgi # set_header ~set_cookies:cookies ~content_type:mime ~filename:file ();
- cgi # environment # send_output_header () ;
- ignore (out_channel # output data 0 (String.length data))
-
- | Json (json,js) ->
- cgi # set_header ~set_cookies:cookies ~content_type:"application/json" ();
- cgi # environment # send_output_header () ;
- let full = add_code (JsBase.to_json js) json in
- let json =
- List.fold_left (fun acc (name,value) ->
- try ignore (List.assoc name acc) ; acc with Not_found -> (name,value) :: acc
- ) [] full
- >> Json_type.Build.objekt
- >> (Json_io.string_of_json ~recursive:true ~compact:true)
- in
- ignore (out_channel # output json 0 (String.length json))
- end
-
- let action_of_path server path =
- let path = path_clean path in
- let rec findstar path removed =
- let attempt = if BS.is_empty path then "*" else path ^ "/*" in
- try Some (Hashtbl.find _path_hash (server, lowercase attempt), removed) with Not_found ->
- if BS.is_empty path then None else
- try let (path,cut) = BS.rsplit path "/" in findstar path (cut::removed)
- with Not_found -> findstar "" (path::removed)
- in try Some (Hashtbl.find _path_hash (server,lowercase path), []) with Not_found -> findstar path []
+let find_strict protocol domain port prefix suffix cgi =
+ let list = Hashtbl.find_all defined (lowercase (path_clean prefix)) in
+ try Some (BatList.find_map (fun candidate -> candidate protocol domain port suffix cgi) list)
+ with Not_found -> None
+
+let slice prefix suffix =
+ try let path, cut = BatString.rsplit prefix "/" in
+ Some (path, cut :: suffix)
+ with Not_found ->
+ if prefix = "" then None else Some ("", prefix :: suffix)
+
+let find protocol domain port path cgi =
+ ensure () ;
+ let rec aux prefix suffix =
+ match find_strict protocol domain port prefix suffix cgi with Some a -> Some a | None ->
+ match slice prefix suffix with None -> None | Some (prefix, suffix) ->
+ aux prefix suffix
+ in aux path []
- exception Action_not_found of string
-
- let dispatch cgi =
-
- let cgi = (cgi :> Netcgi.cgi) in
-
- let env = cgi # environment in
-
- let server = Config.server_of_name (env # cgi_server_name) in
-
- let path = path_clean (env # cgi_script_name) in
-
- let action, args = match action_of_path server path with
- | Some found -> found
- | None -> raise (Action_not_found ("http://"^(_servername server)^"/"^(path)))
- in
-
- let request = (new fcgi_request args cgi :> request) in
+exception Action_not_found of string
- let response = Run.eval () (action request empty) in
-
- _process server cgi response
-
- let run callback =
- Netcgi_fcgi.run
- ~config:{
- Netcgi.default_config with Netcgi.permitted_input_content_types =
- [ "application/json" ; "multipart/form-data" ; "application/x-www-form-urlencoded" ]
- }
- callback
+let dispatch cgi =
+
+ let cgi = (cgi :> Netcgi.cgi) in
+
+ let env = cgi # environment in
+
+ let domain = env # cgi_server_name in
+ let defport, protocol = if env # cgi_https then 443,`HTTPS else 80,`HTTP in
+ let port = BatOption.default defport (env # cgi_server_port) in
+ let path = path_clean (env # cgi_script_name) in
+
+ let cookie_suffix, action = match find protocol domain port path cgi with
+ | Some (cookie_suffix,action) -> cookie_suffix, action
+ | None -> raise (Action_not_found ("http://"^(env # cgi_server_name)^"/"^path))
+ in
+
+ let response = Run.eval () (action empty) in
+
+ process cookie_suffix cgi response
+
+let run callback =
+ Netcgi_fcgi.run
+ ~config:{
+ Netcgi.default_config with Netcgi.permitted_input_content_types =
+ [ "application/json" ; "multipart/form-data" ; "application/x-www-form-urlencoded" ]
+ }
+ callback
+
+module Convenience = struct
+
+ let nilreq s a = new nilreq s a
+
+ let single_domain_server ?(secure=false) ?port ?cookies domain =
+ let defport, protocol = if secure then 443,`HTTPS else 80,`HTTPS in
+ let port = BatOption.default defport port in
+ (object
+ method protocol = protocol
+ method domain () = domain
+ method port () = port
+ method cookie_domain = cookies
+ method matches pr dom po =
+ if po = port && pr = protocol && domain = dom then Some () else None
+ end : unit server)
+
+ let sub_domain_server ?(secure=false) ?port ?cookies suffix =
+ let defport, protocol = if secure then 443,`HTTPS else 80,`HTTPS in
+ let port = BatOption.default defport port in
+ let cut = String.length suffix in
+ (object
+ method protocol = protocol
+ method domain s = s ^ suffix
+ method port _ = port
+ method cookie_domain = cookies
+ method matches pr dom po =
+ if po = port && pr = protocol && BatString.ends_with dom suffix
+ then Some (BatString.left dom (String.length dom - cut)) else None
+ end)
+
+ let root s = server_root s
end
671 src/action.mli
View
@@ -1,105 +1,46 @@
-(* Ohm is © 2011 Victor Nicollet *)
+(* Ohm is © 2012 Victor Nicollet *)
(** The {b Controller} layer: HTTP requests, dispatching, and responses.
+ In normal use situations, the dispatch mechanism is already taken care of by module {!Main}, so
+ all you have to do is define servers and controllers.
+
Whenever the application receives a new request, {!Action.Make.dispatch} would be called
to select the appropriate action and run it, returning the results. The easiest way to do this is to
use [ocamlnet2] FastCGI functionality:
{[ at_exit (fun () -> Netcgi_fcgi.run MyAction.dispatch) ]}
- {2 Usage}
-
- The module should be instantiated early in the controller layer. Then, throughout that layer,
- every module can register one or more actions by creating action functions that implement {!Action.Make.t}
- and then registering them with {!Action.Make.register}.
-
@author Victor Nicollet
@version 1.0
*)
-(** Configuration module type. Used as a parameter for {!Action.Make}.
-
- This is used on multi-server configurations to differentiate between requests sent
- to the various available servers : when registering an action, you specify what server
- that action corresponds to.
-
- For instance, if you have two servers that respond on [blue.domain.com] and [red.domain.com],
- then you would define [type server = Blue | Red], and have [server_of_name] return
- [Blue] for [blue.domain.com] and [Red] for [red.domain.com].
-
- If you don't need to handle multiple domain names, you can use {!Action.SingleServer}.
+(** A server type. A server represents one or more domains, ports and protocols. If more than one
+ domain is supported, then the server has a parameter which specifies which is
+ being used (either for receiving a request, or for generating some HTML).
*)
-module type CONFIG = sig
-
- (** The type of a server. See {!Action.CONFIG} for more information on servers.
-
- A typical implementation in a single-server setup could be {[ type server = TheServer ]}
- *)
- type server
-
- (** The domain name of a server. See {!Action.CONFIG} for more information on servers.
-
- This is used for logging and debugging purposes. It would make sense that:
-
- {[ server_of_name (name_of_server server) = server ]}
-
- However, this is not necessary (except for your own sanity while debugging).
-
- In a single-server setup for the domain name [www.example.com], a typical implementation
- could be {[ let name_of_server _ = "www.example.com" ]}
- *)
- val name_of_server : server -> string
-
- (** Determine the server based on the domain name. See {!Action.CONFIG} for more information
- on servers.
-
- This is used by the dispatcher to determine what server a given request should be
- mapped to. This function has no possibility of returning no value, and should {b not} raise
- an exception. Instead, it is advised to have a catch-all server that can serve a
- decent 404 page.
+class type ['param] server = object
- A typical implementation for a single-server setup could be
- {[ let server_of_name _ = TheServer ]}
- *)
- val server_of_name : string -> server
-
- (** The domain suffix for multi-domain cookies.
-
- When a cookie is generated, it may be shared across several domains that have the same
- suffix. That suffix is returned by this function based on the current server.
- So, if a given server matches all domains of the form [*.domain.com], using a suffix
- of [.domain.com] would make the cookie available to all those domains.
+ (** Is this server HTTP or HTTPS ? *)
+ method protocol : [`HTTP|`HTTPS]
- If no suffix is returned, the cookie will only be available to the precise domain that
- generated it, so [red.domain.com] would not see a cookie set by [blue.domain.com]
+ (** What is the domain name for this server ? *)
+ method domain : 'param -> string
- In a single-server setup, a typical implementation would be
- {[ let server_suffix _ = None ]}
- *)
- val server_suffix : server -> string option
-
-end
+ (** What is the port for this server ? *)
+ method port : 'param -> int
-(** An implementation of {!Action.CONFIG} when you only need to handle one domain name. *)
-module SingleServer : sig
+ (** What is the cookie domain name for this server ? Cookies emitted by this server will be bound
+ to this domain, which may make them available to other servers based on the standard cookie
+ rules. Return [None] to set the cookie only for the current domain. *)
+ method cookie_domain : string option
- (** A singleton type representing only one server. *)
- type server = [ `TheServer ]
-
- (** Returns ["..."] for all inputs. *)
- val name_of_server : server -> string
-
- (** Returns [`TheServer] for all inputs. *)
- val server_of_name : string -> server
-
- (** Returns [None] for all inputs. *)
- val server_suffix : server -> string option
+ (** Does this server match an incoming request ? If so, extract the parameter that can be used to
+ generate another request on this domain. *)
+ method matches : [`HTTP|`HTTPS] -> string -> int -> 'param option
end
-module type CUSTOMIZABLE = sig
-
(** The HTTP response.
The responsibility of the action ({!Action.Make.t}) is to transform a response into another - initially,
@@ -114,68 +55,58 @@ module type CUSTOMIZABLE = sig
The initial response has a JSON Data channel containing an empty object, no cookies, and no javascript.
*)
- type response
-
-
- (** Deprecated. *)
- val html : (View.Context.text View.t -> View.Context.text View.t) -> response -> response
-
- (** {b HTML Page}: responds with a web page. The contents are provided as a string, for instance
- one generated with {!val:Html.render_page}.
-
- {[
-module Act = Action.Make(SingleServer)
-
-Act.register (...) begin fun request response ->
- return $ Act.page "<html><head/><body>Hello, world!</body></html>" response
+type response
+
+(** {b HTML Page}: responds with a web page. The contents are provided as a function that
+ takes a bit of javascript as argument and returns a string, for instance the function
+ returned by {!val:Html.render_page}.
+
+ {[
+Action.register (...) begin fun request response ->
+ let html = Html.str "<b>Hello, world!</b>" in
+ return $ Act.page (Html.render_page html) response
end
- ]}
- *)
- val page : string -> response -> response
+ ]}
+*)
+val page : (JsCode.t -> string) -> response -> response
- (** {b Redirect}: creates a 303 See Other HTTP redirect to the specified absolute URL. Data and JavaScript
- channels are erased, Cookies are kept.
+(** {b Redirect}: creates a 303 See Other HTTP redirect to the specified absolute URL. Data and JavaScript
+ channels are erased, Cookies are kept.
{[
-module Act = Action.Make(SingleServer)
-
-Act.register (...) begin fun request response ->
+Action.register (...) begin fun request response ->
return $ Act.redirect "http://www.example.com/foo/bar?qux=baz" response
end
- ]}
- *)
- val redirect : string -> response -> response
-
- (** {b JSON}: return JSON-formatted data. It always returns an object, as
- other values can cause security issues. So [\{ok:\[1,2,3\]\}] can be returned but [\[1,2,3\]] cannot.
- This is merged with the previously available data in the Data channel if it was JSON - merging is
- not recursive and happens on a per-field basis, so subsequent transforms adding distinct fields
- accumulate data rather than replacing it. Be careful: the [code] field is overwritten by
- JavaScript data.
+ ]}
+*)
+val redirect : string -> response -> response
- {[
-module Act = Action.Make(SingleServer)
+(** {b JSON}: return JSON-formatted data. It always returns an object, as
+ other values can cause security issues. So [\{ok:\[1,2,3\]\}] can be returned but [\[1,2,3\]] cannot.
+ This is merged with the previously available data in the Data channel if it was JSON - merging is
+ not recursive and happens on a per-field basis, so subsequent transforms adding distinct fields
+ accumulate data rather than replacing it. Be careful: the [code] field is overwritten by
+ JavaScript data.
-Act.register (...) begin fun request response ->
+ {[
+Action.register (...) begin fun request response ->
let json = [
"ok", Json_type.Build.list Json_type.Build.int [ 1 ; 2 ; 3 ]
] in
return $ Act.json json response
end
- ]}
- *)
- val json : (string * Json_type.t) list -> response -> response
-
- (** {b Cookies}: add a cookie on top of another response. The cookie lifetime is specified in
- seconds starting from the time the response is generated ({i not} 01/01/1970), a value of
- zero means the cookie disappears when the browser is closed. Cookies are independent
- of Data and JavaScript channels.
+ ]}
+*)
+val json : (string * Json_type.t) list -> response -> response
- {[
-module Act = Action.Make(SingleServer)
+(** {b Cookies}: add a cookie on top of another response. The cookie lifetime is specified in
+ seconds starting from the time the response is generated ({i not} 01/01/1970), a value of
+ zero means the cookie disappears when the browser is closed. Cookies are independent
+ of Data and JavaScript channels.
-Act.register (...) begin fun request response ->
+ {[
+Action.register (...) begin fun request response ->
let cookie_name = "SESSION" in
let cookie_value = "ses-13F438A" in
let cookie_life = 3600 in
@@ -183,19 +114,17 @@ Act.register (...) begin fun request response ->
return $ Act.with_cookie ~name:cookie_name ~value:cookie_value ~life:cookie_life response
end
- ]}
-
- It is of course possible to set multiple cookies in one response.
- *)
- val with_cookie : name:string -> value:string -> life:int -> response -> response
+ ]}
+
+ It is of course possible to set multiple cookies in one response.
+*)
+val with_cookie : name:string -> value:string -> life:int -> response -> response
- (** {b Files}: return an attached file for downloading. One should provide the
- file name, the MIME type of the file, and a view used to render the file
- data itself. This overwrites any Data and JavaScript channels, but conserves Cookies.
-
- {[
-module Act = Action.Make(SingleServer)
+(** {b Files}: return an attached file for downloading. One should provide the
+ file name, the MIME type of the file, and a view used to render the file
+ data itself. This overwrites any Data and JavaScript channels, but conserves Cookies.
+ {[
Act.register (...) begin fun request response ->
let mime = "text/plain"
let file = "hello.txt"
@@ -203,284 +132,288 @@ Act.register (...) begin fun request response ->
return $ Act.file ~file ~mime ~data response
end
- ]}
- *)
- val file : file:string -> mime:string -> data:string -> response -> response
-
- (** {b JavaScript}: attaches some JavaScript to be executed after an HTML or JSON response.
- If the response is HTML, the view will receive the JavaScript code (turned to a string) as
- a parameter to insert it into an appropriate script tag. If the response is JSON, a [code]
- field will be added to the final JSON (if it's not an object, it will become one and previous
- data will be lost). JavaScript appears in the same order it was added to the response.
-
- If the Data channel is neither HTML nor JSON, it is reset with an empty JSON object. If this
- is not the desired behavior, use {!Action.Response.more_javascript} instead.
-
- {[
-module Act = Action.Make(SingleServer)
+ ]}
+*)
+val file : file:string -> mime:string -> data:string -> response -> response
-Act.register (...) begin fun request response ->
+(** {b JavaScript}: attaches some JavaScript to be executed after an HTML or JSON response.
+ If the response is HTML, the view will receive the JavaScript code (turned to a string) as
+ a parameter to insert it into an appropriate script tag. If the response is JSON, a [code]
+ field will be added to the final JSON (if it's not an object, it will become one and previous
+ data will be lost). JavaScript appears in the same order it was added to the response.
+
+ If the Data channel is neither HTML nor JSON, it is reset with an empty JSON object. If this
+ is not the desired behavior, use {!Action.Response.more_javascript} instead.
+
+ {[
+Action.register (...) begin fun request response ->
let code = JsBase.init in
return $ Act.javascript code response
end
- ]}
- *)
- val javascript : JsCode.t -> response -> response
-
- (** {b Append-Only JavaScript}: works as {!Action.Response.javascript}, but does not overwrite
- the response if it was neither HTML nor JSON.
+ ]}
+*)
+val javascript : JsCode.t -> response -> response
- {[
-module Act = Action.Make(SingleServer)
+(** {b Append-Only JavaScript}: works as {!Action.Response.javascript}, but does not overwrite
+ the response if it was neither HTML nor JSON.
+ {[
Act.register (...) begin fun request response ->
let code = JsBase.init in
return $ Act.more_javascript code response
end
- ]}
+ ]}
*)
- val more_javascript : JsCode.t -> response -> response
+val more_javascript : JsCode.t -> response -> response
- (** The data carried by an HTTP request.
- An object of this type is provided to the action that the request was dispatched to
- (method {!method:Action.Make.t}).
- *)
- class type request =
- object
+(** The data carried by an HTTP request.
+*)
+class type ['server,'args] request = object
- (** The path that appears after the domain name in the URL.
-
- Note that the path is cleaned by removing initial and trailing slashes, as well as the query string.
- So, [http://domain.com/a/b/c/?q=foo] yields a path of [a/b/c].
- *)
- method path : string
-
- (** The server hostname.
-
- This is usually the domain name, possibly overwritten by the server configuration.
- In general, [http://sub.domain.com/foo/bar] yields a server name of [sub.domain.com].
- *)
- method servername : string
-
- (** Extract the request format.
-
- The format determines whether request data is available through {!post} or {!json}
- methods.
- *)
- method format : [ `JSON | `URLENCODED ]
-
- (** Extracts a named parameter from the request, if present.
-
- Returns nothing if the format is not [`URLENCODED].
-
- If the script was called with a query string of [?foo=bar], then [request # post "foo"] yields
- [Some "bar"] and [request # post "qux"] yields [None]. In the case of a POST request, the
- POST parameters will shadow the query string parameters with the same name.
-
- It is not advised to use several parameters with the same name. Should this happen, only the
- last parameter will be kept.
- *)
- method post : string -> string option
-
- (** Extracts all named parameters from the request.
-
- Returns nothing if the format is not [`URLENCODED].
-
- The list contains key-value pairs. For instance, if the query string is [?foo=bar&baz=qux], then
- [request # postlist] yields [\[ "foo","bar" ; "baz","qux" \]]. The same applies to POST
- parameters, if any.
- *)
- method postlist : (string * string) list
-
- (** Extracts the JSON content of the request.
-
- Returns [Json_type.Null] if the format is not [`JSON].
- *)
- method json : Json_type.t
-
- (** Extracts an argument from the wildcard section of the path.
-
- If the action path ends in a wildcard (such as [/user/*]), the path segments matched by the
- wildcard are parsed and split into a list. So, in the case of [/user/00fC3Q023jZ/edit] handled
- by an action with a path of [/user/*], [request # args 0] yields [Some "00fC3Q023jZ"],
- [request # args 1] yields [Some "edit"] and [request # args 0] yields [None].
-
- More information about action paths can be found in {!Action.Make.controller.path}.
- *)
- method args : int -> string option
-
- (** Extracts the value of a cookie, if set.
-
- If a cookie [SESSION=0Z23yB] is sent by the browser, then [request # cookie "SESSION"] will
- return [Some "0Z23yB"]. If no cookie by that name is sent, the method returns [None].
- *)
- method cookie : string -> string option
+ (** The server-provided data, of the same type as the server parameter.
+ *)
+ method server : 'server
+
+ (** The path that appears after the domain name in the URL.
- (** The complete query received by the server.
-
- For example, [http://www.example.com/foo/bar?qux=baz]. This method serves no practical purpose,
- except in some query logging situations.
- *)
- method query : string
+ Note that the path is cleaned by removing initial and trailing slashes, as well as the query string.
+ So, [http://domain.com/a/b/c/?q=foo] yields a path of [a/b/c].
+ *)
+ method path : string
- (** The IP address of the HTTP client.
-
- The address is provided in an unspecified format (IPv4, IPv6 or a host name) and should be processed
- with appropriate IP-friendly functions of your choice before being used. It can serve as a
- cheap-and-unstable unique visitor token if you really need one, but you really shouldn't as many ISPs
- and proxies will break such attempts.
- *)
- method ip : string
-
- end
-
- (** An action - provided by user code to respond to requests.
-
- Actions are registered with the system using {!val:Action.Make.register}. Then, {!val:Action.Make.dispatch}
- finds the appropriate action to respond to a given HTTP request based on the provided {!class:Action.Make.controller}
- and calls the function to obtain the response, which is then sent back to the
- client.
- *)
- type t = request -> response -> (unit,response) Run.t
-
- (** An alias to a server type. *)
- type server
-
- (** Determines what URL and server an action maps to.
-
- The parameters are the server (see {!modtype:Action.CONFIG} for details) and the URL.
-
- For instance, for an action to match the URL [http://red.example.com/test/url], its
- controller would be defined as:
-
- {[
-let _ = Act.register (Act.Red,"test/url") action
- ]}
-
- The path may contain a {b wildcard} to match several different URLs with the same
- suffix. To match the URL [http://red.example.com/view/<id>] for every possible [<id>],
- one would define the action as:
-
- {[
-let _ = Act.register (Act.Red,"view/*") action
- ]}
-
- The [<id>] would then be available in the [run] method as [request # args 0] (see
- {!method:Action.Make.request.args} for more information).
-
- Note that only one wildcard is allowed, and it must be the final segment. [/foo/*/bar],
- [/foo/bar/*/*] and [/foo/bar*] are {b illegal} and the misplaced [*] is treated as a normal character.
-
- Note that without a wildcard, the action only matches the exact path that was
- provided, so that a path of [foo/bar] would match URLs [/foo/bar/], [/foo//bar/]
- and [/foo/bar], but not [/foo/bar/qux].
-
- If several wildcard controllers match the same URL, the one with the longest initial
- match is kept (so, for [/foo/bar/qux], [/foo/bar/*] would be picked over [/foo/*]).
+ (** Extract the request data which has been provided either as a field-and-value standard [`POST]
+ or as a single [`JSON] value.
+ *)
+ method post : [ `JSON of Json_type.t | `POST of (string,string) BatPMap.t ] option
+
+ (** Extract additional [GET] parameters from the query string.
+ *)
+ method get : string -> string option
+
+ (** The arguments extracted by the wildcard section of the path.
+ *)
+ method args : 'args
- It is strongly advised to provide a wildcard path ([*]) for every server to act
- as a 404 page. Otherwise, {!exception:Action.Make.Action_not_found} will be raised.
+ (** Extracts the value of a cookie, if set.
+ If a cookie [SESSION=0Z23yB] is sent by the browser, then [request # cookie "SESSION"] will
+ return [Some "0Z23yB"]. If no cookie by that name is sent, the method returns [None].
*)
- type controller = server * string
+ method cookie : string -> string option
+
+end
- (** Raised when no actions match a specific request. Should be avoided by registering an action with
- a {!class:Action.Make.controller} that has a path of ["*"] to handle 404 errors.
- *)
- exception Action_not_found of string
+(** An action - provided by user code to respond to requests.
- (** Computes the action that matches a path.
-
- This is what {!val:Action.Make.dispatch} does internally. The provided arguments are the current
- server and the complete URL path, and the function returns the action's [run] method and the
- list of segments matched by the wildcard in the action's path.
-
- For instance:
-
- {[
-module Act = Action.Make(Action.SingleServer)
-
-let () = Act.register (`TheServer,"foo/*") foo_handler
-
-let a = Act.action_of_path `TheServer "foo/bar/qux"
-let b = Act.action_of_path `TheServer "bar"
- ]}
-
- Here, [a] is [Some (foo_handler, \["bar";"qux"\])] and [b] is [None].
+ Actions are registered with the system using {!val:Action.Make.register}. Then, {!val:Action.Make.dispatch}
+ finds the appropriate action to respond to a given HTTP request based on the provided {!class:Action.Make.controller}
+ and calls the function to obtain the response, which is then sent back to the
+ client.
+*)
+type ('args,'params) t = ('args,'params) request -> response -> (unit,response) Run.t
+
+(** Parsing arguments.
+
+ It determines how segments present in the provided path after the matched path prefix.
+ That is, if an action matches path prefix ["foo/bar"] and a request provides path
+ ["foo/bar/baz/quux"], then the argument parser decides what should happen with
+ segments ["baz"] and ["quux"], and whether they should be accepted or not.
+*)
+module Args : sig
+
+ (** The type of a cell parser - a two-way function that turns strings into the
+ ultimate type, and back. The from-string conversion may fail, which causes
+ the match to fail as well.
+ *)
+ type 'a cell = ('a -> string) * (string -> 'a option)
- Note that only actions registered with {!val:Action.Make.register} on the same module can be found
- with this function.
- So, the following returns [None]:
+ (** A string cell. *)
+ val string : string cell
- {[
-module Act = Action.Make(Action.SingleServer)
+ (** An integer cell. *)
+ val int : int cell
-let _ = Act.register (`TheServer,"foo/*") foo_handler
+ (** The type of an argument parser.
+ *)
+ type 'args t = ('args -> string list) * (string list -> 'args option)
-module Act = Action.Make(Action.SingleServer)
+ (** Try to parse an argument list using a parser. *)
+ val parse : 'args t -> string list -> 'args option
-let a = Act.action_of_path `TheServer "foo/bar/qux"
- ]}
+ (** Generate a string list from a parser and some arguments. *)
+ val generate : 'args t -> 'args -> string list
- {b Make sure your entire application only contains one call to the {!module:Action.Make} functor!}
+ (** No arguments. If the provided path is not equal to the path prefix, then no match
+ occurs and the action is not executed.
*)
- val action_of_path : server -> string -> (t * string list) option
+ val none : unit t
- (** Dispatch a FastCGI request.
+ (** The functions below are all built on the same naming principles [[ro]{0,4}[in]?]
+ Each [r] indicates a required argument. Each [o] indicates an optional argument.
+ A final [n] indicates that additional parameters are returned as a list. A final
+ [i] indicates that additional parameters are ignored.
+ *)
+
+ val r : 'a cell -> 'a t
+ val rr : 'a cell -> 'b cell -> ('a * 'b) t
+ val rrr : 'a cell -> 'b cell -> 'c cell -> ('a * 'b * 'c) t
+ val rrrr : 'a cell -> 'b cell -> 'c cell -> 'd cell -> ('a * 'b * 'c * 'd) t
+ val o : 'a cell -> 'a option t
+ val ro : 'a cell -> 'b cell -> ('a * 'b option) t
+ val oo : 'a cell -> 'b cell -> ('a option * 'b option) t
+ val rro : 'a cell -> 'b cell -> 'c cell -> ('a * 'b * 'c option) t
+ val roo : 'a cell -> 'b cell -> 'c cell -> ('a * 'b option * 'c option) t
+ val ooo : 'a cell -> 'b cell -> 'c cell -> ('a option * 'b option * 'c option) t
+ val rrro : 'a cell -> 'b cell -> 'c cell -> 'd cell -> ('a * 'b * 'c * 'd option) t
+ val rroo : 'a cell -> 'b cell -> 'c cell -> 'd cell -> ('a * 'b * 'c option * 'd option) t
+ val rooo : 'a cell -> 'b cell -> 'c cell -> 'd cell -> ('a * 'b option * 'c option * 'd option) t
+ val oooo : 'a cell -> 'b cell -> 'c cell -> 'd cell -> ('a option * 'b option * 'c option * 'd option) t
+
+ val i : unit t
+ val ri : 'a cell -> 'a t
+ val rri : 'a cell -> 'b cell -> ('a * 'b) t
+ val rrri : 'a cell -> 'b cell -> 'c cell -> ('a * 'b * 'c) t
+ val rrrri : 'a cell -> 'b cell -> 'c cell -> 'd cell -> ('a * 'b * 'c * 'd) t
+ val oi : 'a cell -> 'a option t
+ val roi : 'a cell -> 'b cell -> ('a * 'b option) t
+ val ooi : 'a cell -> 'b cell -> ('a option * 'b option) t
+ val rroi : 'a cell -> 'b cell -> 'c cell -> ('a * 'b * 'c option) t
+ val rooi : 'a cell -> 'b cell -> 'c cell -> ('a * 'b option * 'c option) t
+ val oooi : 'a cell -> 'b cell -> 'c cell -> ('a option * 'b option * 'c option) t
+ val rrroi : 'a cell -> 'b cell -> 'c cell -> 'd cell -> ('a * 'b * 'c * 'd option) t
+ val rrooi : 'a cell -> 'b cell -> 'c cell -> 'd cell -> ('a * 'b * 'c option * 'd option) t
+ val roooi : 'a cell -> 'b cell -> 'c cell -> 'd cell -> ('a * 'b option * 'c option * 'd option) t
+ val ooooi : 'a cell -> 'b cell -> 'c cell -> 'd cell -> ('a option * 'b option * 'c option * 'd option) t
+
+ val n : 'a cell -> 'a list t
+ val rn : 'a cell -> 'l cell -> ('a * 'l list) t
+ val rrn : 'a cell -> 'b cell -> 'l cell -> ('a * 'b * 'l list) t
+ val rrrn : 'a cell -> 'b cell -> 'c cell -> 'l cell -> ('a * 'b * 'c * 'l list) t
+ val rrrrn : 'a cell -> 'b cell -> 'c cell -> 'd cell -> 'l cell -> ('a * 'b * 'c * 'd * 'l list) t
+ val on : 'a cell -> 'l cell -> ('a option * 'l list) t
+ val ron : 'a cell -> 'b cell -> 'l cell -> ('a * 'b option * 'l list) t
+ val oon : 'a cell -> 'b cell -> 'l cell -> ('a option * 'b option * 'l list) t
+ val rron : 'a cell -> 'b cell -> 'c cell -> 'l cell -> ('a * 'b * 'c option * 'l list) t
+ val roon : 'a cell -> 'b cell -> 'c cell -> 'l cell -> ('a * 'b option * 'c option * 'l list) t
+ val ooon : 'a cell -> 'b cell -> 'c cell -> 'l cell -> ('a option * 'b option * 'c option * 'l list) t
+ val rrron : 'a cell -> 'b cell -> 'c cell -> 'd cell -> 'l cell -> ('a * 'b * 'c * 'd option * 'l list) t
+ val rroon : 'a cell -> 'b cell -> 'c cell -> 'd cell -> 'l cell -> ('a * 'b * 'c option * 'd option * 'l list) t
+ val rooon : 'a cell -> 'b cell -> 'c cell -> 'd cell -> 'l cell -> ('a * 'b option * 'c option * 'd option * 'l list) t
+ val oooon : 'a cell -> 'b cell -> 'c cell -> 'd cell -> 'l cell -> ('a option * 'b option * 'c option * 'd option * 'l list) t
- This function extracts the appropriate action using {!val:Action.Make.action_of_path}, calls its
- {!method:Action.Make.t.run} method and then sends the result back to the HTTP client.
+end
- Typical usage:
+(** Determines what URL and server an action maps to.
- {[ at_exit (fun () -> Act.run Act.dispatch) ]}
+ Contains a server, a path prefix and an argument parser. When a request must be dispatched,
+ every action is checked to determine whether its controller matches the request. One of
+ the actions that match the request is then selected (the one with the longest path prefix or,
+ if both are the same size, an arbitrary but deterministic one).
+
+ For instance, for an action to match the URL [http://red.example.com/test/url],
+ its controller would be defined as:
+
+ {[
+let red = Action.Convenience.single_domain_server "red.example.com" in
+let _ = Action.(register (red,"test/url",Args.none)) action
+ ]}
- Here, [at_exit] is used to ensure that all global calls to {!val:Action.Make.register} have been
- performed before [Netcgi_fcgi.run] is called.
+ The argument parser may allow the matching of paths longer than the prefix path.
+ To match the URL [http://red.example.com/user/<id>] for every possible (but mandatory)
+ [<id>] string, one would define the action as:
- @raise Action.Make.Action_not_found if no matching action is found.
- *)
- val dispatch : #Netcgi.cgi -> unit
+ {[
+let _ = Action.(register (red,"view",Args.(r string))) action
+ ]}
- (** Register an action with the dispatcher.
+ The [<id>] would then be available in the [run] method as [request # args] (see
+ {!method:Action.request.args} for more information).
+*)
+type ('server,'args) controller = 'server server * string * 'args Args.t
- This allows the action to be found by {!val:Action.Make.action_of_path} and {!val:Action.Make.dispatch}.
- For instance:
+(** Raised when no actions match a specific request. Should be avoided by registering an action with
+ a {!class:Action.Make.controller} that has a path of ["*"] to handle 404 errors.
+*)
+exception Action_not_found of string
+
+(** An endpoint is a controller that has been bound to an action and can be converted to an URL
+ by receiving all the parameters required to fill in the path and domain. *)
+type ('server,'args) endpoint
- {[
-module Act = Action.Make(Action.SingleServer)
+(** The URL of an endpoint. *)
+val url : ('server,'args) endpoint -> 'server -> 'args -> string
+
+(** Dispatch a FastCGI request.
+
+ This function extracts the appropriate action, runs it, then sends the result back
+ to the HTTP client.
+
+ This should be handled by module {!Main}. If not, you can use:
+
+ {[ at_exit (fun () -> Action.run Action.dispatch) ]}
+
+ Here, [at_exit] is used to ensure that all global calls to {!val:Action.register} have been
+ performed before [Netcgi_fcgi.run] is called.
+
+ @raise Action.Make.Action_not_found if no matching action is found.
+*)
+val dispatch : #Netcgi.cgi -> unit
-let () = Act.register (`TheServer,"foo/*") foo_handler
+(** Register an action with the dispatcher.
+
+ This allows the action to be found by {!val:Action.resolve} and {!val:Action.dispatch}.
-let a = Act.action_of_path `TheServer "foo/bar/qux"
- ]}
+ Registering an action returns an endpoint that you can use to
+*)
+val register : ('server,'args) controller -> ('server,'args) t -> ('server,'args) endpoint
- This sucessfully returns [Some (foo_handler, \["bar";"qux"\])].
+(** Declare an action with the dispatcher. This helps return the endpoint before the actual
+ action has been defined, and so helps with mutually recursive functions or simply
+ defining [Url] modules that contain undefined endpoints.
- Note that only actions registered on the same module can be found. So, the following returns [None]:
+ {[
+(* urls.ml *)
+let endpoint, define = Action.declare controller
- {[
-module Act = Action.Make(Action.SingleServer)
+(* actions.ml *)
+let () = Urls.define action
+ ]}
-let () = Act.register (`TheServer,"foo/*") foo_handler
+ A warning will be logged if {!Action.dispatch}, {!Action.resolve} or {!Action.run}
+ are called before all declared endpoints are defined, or if an endpoint is defined
+ twice.
-module Act = Action.Make(Action.SingleServer)
+*)
+val declare :
+ ('server,'args) controller
+ -> ('server,'args) endpoint * (('server,'args) t -> unit)
+
+(** Run the Fastcgi server with the appropriate default configuration. *)
+val run : (Netcgi_fcgi.cgi -> unit) -> unit
+
+(** Helper functions for your convenience. *)
+module Convenience : sig
+
+ (** A server that responds to a single domain.
+ [let server = single_domain_server "www.domain.com"].
+ *)
+ val single_domain_server : ?secure:bool -> ?port:int -> ?cookies:string -> string -> unit server
-let a = Act.action_of_path `TheServer "foo/bar/qux"
- ]}
+ (** A server that responds to multiple subdomains of a given domain.
+ [let server = sub_comain_server ".domain.com"] would match [foo.domain.com] but
+ not [domain.com].
+ *)
+ val sub_domain_server : ?secure:bool -> ?port:int -> ?cookies:string -> string -> string server
- {b Make sure your entire application only contains one call to the {!module:Action.Make} functor!}
+ (** Generate the root URL of a server. This returns a string of the
+ form [http://example.com:666]
+ *)
+ val root : 'param server -> 'param -> string
- This function returns the action, just in case you need to do something with it, but most of
- the time it will be ignored.
+ (** A request that carries no cookies, get or post data, it only contains server and path info
+ provided upon creation. This function is not typically useful, but serves as a convenient
+ when using {!Action.resolve}.
*)
- val register : controller -> t -> unit
+ val nilreq : 'server -> 'args -> ('server,'args) request
- (** Run the Fastcgi server with the appropriate default configuration. *)
- val run : (Netcgi_fcgi.cgi -> unit) -> unit
-
end
-
-(** Construction functor. *)
-module Customize : functor (Config:CONFIG) -> CUSTOMIZABLE with type server = Config.server
-
1,010 src/action_Args.ml
View
@@ -0,0 +1,1010 @@
+type 'a cell = ('a -> string) * (string -> 'a option)
+type 'args t = ('args -> string list) * (string list -> 'args option)
+
+let string = (fun str -> str), (fun str -> Some str)
+let int = string_of_int, (fun i -> try Some (int_of_string i) with _ -> None)
+
+let parse (_,f) list = f list
+let generate (g,_) args = g args
+
+let none = (fun () -> []), (function [] -> Some () | _ -> None)
+let i = (fun () -> []), (fun _ -> Some ())
+let n (f,g) = (fun l -> List.map f l), (fun l -> let l' = BatList.filter_map g l in
+ if List.length l' <> List.length l then None else Some l')
+
+(* The source below was mass-generated. *)
+
+let on (gen1, parse1) (genL, parseL) =
+ (function
+ | (Some x1,l) -> (gen1 x1) :: List.map genL l
+ | (_,_) -> []
+ ),
+ (function
+ | x1 :: l -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ let l' = BatList.filter_map parseL l in
+ if List.length l' <> List.length l then None else
+ Some (Some y1,l')
+ end
+ | [] -> begin
+ Some (None,[])
+ end)
+
+let oi (gen1, parse1) =
+ (function
+ | (Some x1) -> (gen1 x1) :: []
+ | (_) -> []
+ ),
+ (function
+ | x1 :: _ -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ Some (Some y1)
+ end
+ | [] -> Some (None))
+
+let o (gen1, parse1) =
+ (function
+ | (Some x1) -> (gen1 x1) :: []
+ | (_) -> []
+ ),
+ (function
+ | x1 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ Some (Some y1)
+ end
+ | [] -> Some (None)
+ | _ -> None)
+
+let oon (gen1, parse1) (gen2, parse2) (genL, parseL) =
+ (function
+ | (Some x1,Some x2,l) -> (gen1 x1) :: (gen2 x2) :: List.map genL l
+ | (Some x1,_,_) -> (gen1 x1) :: []
+ | (_,_,_) -> []
+ ),
+ (function
+ | x1 :: x2 :: l -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ let l' = BatList.filter_map parseL l in
+ if List.length l' <> List.length l then None else
+ Some (Some y1,Some y2,l')
+ end
+ | x1 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ Some (Some y1,None,[])
+ end
+ | [] -> begin
+ Some (None,None,[])
+ end)
+
+let ooi (gen1, parse1) (gen2, parse2) =
+ (function
+ | (Some x1,Some x2) -> (gen1 x1) :: (gen2 x2) :: []
+ | (Some x1,_) -> (gen1 x1) :: []
+ | (_,_) -> []
+ ),
+ (function
+ | x1 :: x2 :: _ -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (Some y1,Some y2)
+ end
+ | x1 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ Some (Some y1,None)
+ end
+ | [] -> begin
+ Some (None,None)
+ end)
+
+let oo (gen1, parse1) (gen2, parse2) =
+ (function
+ | (Some x1,Some x2) -> (gen1 x1) :: (gen2 x2) :: []
+ | (Some x1,_) -> (gen1 x1) :: []
+ | (_,_) -> []
+ ),
+ (function
+ | x1 :: x2 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (Some y1,Some y2)
+ end
+ | x1 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ Some (Some y1,None)
+ end
+ | [] -> begin
+ Some (None,None)
+ end
+ | _ -> None)
+
+let ooon (gen1, parse1) (gen2, parse2) (gen3, parse3) (genL, parseL) =
+ (function
+ | (Some x1,Some x2,Some x3,l) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: List.map genL l
+ | (Some x1,Some x2,_,_) -> (gen1 x1) :: (gen2 x2) :: []
+ | (Some x1,_,_,_) -> (gen1 x1) :: []
+ | (_,_,_,_) -> []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: l -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ let l' = BatList.filter_map parseL l in
+ if List.length l' <> List.length l then None else
+ Some (Some y1,Some y2,Some y3,l')
+ end
+ | x1 :: x2 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (Some y1,Some y2,None,[])
+ end
+ | x1 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ Some (Some y1,None,None,[])
+ end
+ | [] -> begin
+ Some (None,None,None,[])
+ end)
+
+let oooi (gen1, parse1) (gen2, parse2) (gen3, parse3) =
+ (function
+ | (Some x1,Some x2,Some x3) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: []
+ | (Some x1,Some x2,_) -> (gen1 x1) :: (gen2 x2) :: []
+ | (Some x1,_,_) -> (gen1 x1) :: []
+ | (_,_,_) -> []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: _ -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ Some (Some y1,Some y2,Some y3)
+ end
+ | x1 :: x2 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (Some y1,Some y2,None)
+ end
+ | x1 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ Some (Some y1,None,None)
+ end
+ | [] -> begin
+ Some (None,None,None)
+ end)
+
+let ooo (gen1, parse1) (gen2, parse2) (gen3, parse3) =
+ (function
+ | (Some x1,Some x2,Some x3) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: []
+ | (Some x1,Some x2,_) -> (gen1 x1) :: (gen2 x2) :: []
+ | (Some x1,_,_) -> (gen1 x1) :: []
+ | (_,_,_) -> []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ Some (Some y1,Some y2,Some y3)
+ end
+ | x1 :: x2 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (Some y1,Some y2,None)
+ end
+ | x1 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ Some (Some y1,None,None)
+ end
+ | [] -> begin
+ Some (None,None,None)
+ end
+ | _ -> None)
+
+let oooon (gen1, parse1) (gen2, parse2) (gen3, parse3) (gen4, parse4) (genL, parseL) =
+ (function
+ | (Some x1,Some x2,Some x3,Some x4,l) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: (gen4 x4) :: List.map genL l
+ | (Some x1,Some x2,Some x3,_,_) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: []
+ | (Some x1,Some x2,_,_,_) -> (gen1 x1) :: (gen2 x2) :: []
+ | (Some x1,_,_,_,_) -> (gen1 x1) :: []
+ | (_,_,_,_,_) -> []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: x4 :: l -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ match parse4 x4 with None -> None | Some y4 ->
+ let l' = BatList.filter_map parseL l in
+ if List.length l' <> List.length l then None else
+ Some (Some y1,Some y2,Some y3,Some y4,l')
+ end
+ | x1 :: x2 :: x3 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ Some (Some y1,Some y2,Some y3,None,[])
+ end
+ | x1 :: x2 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (Some y1,Some y2,None,None,[])
+ end
+ | x1 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ Some (Some y1,None,None,None,[])
+ end
+ | [] -> begin
+ Some (None,None,None,None,[])
+ end)
+
+let ooooi (gen1, parse1) (gen2, parse2) (gen3, parse3) (gen4, parse4) =
+ (function
+ | (Some x1,Some x2,Some x3,Some x4) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: (gen4 x4) :: []
+ | (Some x1,Some x2,Some x3,_) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: []
+ | (Some x1,Some x2,_,_) -> (gen1 x1) :: (gen2 x2) :: []
+ | (Some x1,_,_,_) -> (gen1 x1) :: []
+ | (_,_,_,_) -> []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: x4 :: _ -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ match parse4 x4 with None -> None | Some y4 ->
+ Some (Some y1,Some y2,Some y3,Some y4)
+ end
+ | x1 :: x2 :: x3 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ Some (Some y1,Some y2,Some y3,None)
+ end
+ | x1 :: x2 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (Some y1,Some y2,None,None)
+ end
+ | x1 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ Some (Some y1,None,None,None)
+ end
+ | [] -> begin
+ Some (None,None,None,None)
+ end)
+
+let oooo (gen1, parse1) (gen2, parse2) (gen3, parse3) (gen4, parse4) =
+ (function
+ | (Some x1,Some x2,Some x3,Some x4) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: (gen4 x4) :: []
+ | (Some x1,Some x2,Some x3,_) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: []
+ | (Some x1,Some x2,_,_) -> (gen1 x1) :: (gen2 x2) :: []
+ | (Some x1,_,_,_) -> (gen1 x1) :: []
+ | (_,_,_,_) -> []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: x4 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ match parse4 x4 with None -> None | Some y4 ->
+ Some (Some y1,Some y2,Some y3,Some y4)
+ end
+ | x1 :: x2 :: x3 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ Some (Some y1,Some y2,Some y3,None)
+ end
+ | x1 :: x2 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (Some y1,Some y2,None,None)
+ end
+ | x1 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ Some (Some y1,None,None,None)
+ end
+ | [] -> begin
+ Some (None,None,None,None)
+ end
+ | _ -> None)
+
+let rn (gen1, parse1) (genL, parseL) =
+ (function
+ | (x1,l) -> (gen1 x1) :: List.map genL l
+ ),
+ (function
+ | x1 :: l -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ let l' = BatList.filter_map parseL l in
+ if List.length l' <> List.length l then None else
+ Some (y1,l')
+ end
+ | _ -> None)
+
+let ri (gen1, parse1) =
+ (function
+ | (x1) -> (gen1 x1) :: []
+ ),
+ (function
+ | x1 :: _ -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ Some (y1)
+ end
+ | _ -> None)
+
+let r (gen1, parse1) =
+ (function
+ | (x1) -> (gen1 x1) :: []
+ ),
+ (function
+ | x1 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ Some (y1)
+ end
+ | _ -> None)
+
+let ron (gen1, parse1) (gen2, parse2) (genL, parseL) =
+ (function
+ | (x1,Some x2,l) -> (gen1 x1) :: (gen2 x2) :: List.map genL l
+ | (x1,_,_) -> (gen1 x1) :: []
+ ),
+ (function
+ | x1 :: x2 :: l -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ let l' = BatList.filter_map parseL l in
+ if List.length l' <> List.length l then None else
+ Some (y1,Some y2,l')
+ end
+ | x1 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ Some (y1,None,[])
+ end
+ | _ -> None)
+
+let roi (gen1, parse1) (gen2, parse2) =
+ (function
+ | (x1,Some x2) -> (gen1 x1) :: (gen2 x2) :: []
+ | (x1,_) -> (gen1 x1) :: []
+ ),
+ (function
+ | x1 :: x2 :: _ -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (y1,Some y2)
+ end
+ | x1 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ Some (y1,None)
+ end
+ | _ -> None)
+
+let ro (gen1, parse1) (gen2, parse2) =
+ (function
+ | (x1,Some x2) -> (gen1 x1) :: (gen2 x2) :: []
+ | (x1,_) -> (gen1 x1) :: []
+ ),
+ (function
+ | x1 :: x2 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (y1,Some y2)
+ end
+ | x1 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ Some (y1,None)
+ end
+ | _ -> None)
+
+let roon (gen1, parse1) (gen2, parse2) (gen3, parse3) (genL, parseL) =
+ (function
+ | (x1,Some x2,Some x3,l) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: List.map genL l
+ | (x1,Some x2,_,_) -> (gen1 x1) :: (gen2 x2) :: []
+ | (x1,_,_,_) -> (gen1 x1) :: []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: l -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ let l' = BatList.filter_map parseL l in
+ if List.length l' <> List.length l then None else
+ Some (y1,Some y2,Some y3,l')
+ end
+ | x1 :: x2 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (y1,Some y2,None,[])
+ end
+ | x1 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ Some (y1,None,None,[])
+ end
+ | _ -> None)
+
+let rooi (gen1, parse1) (gen2, parse2) (gen3, parse3) =
+ (function
+ | (x1,Some x2,Some x3) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: []
+ | (x1,Some x2,_) -> (gen1 x1) :: (gen2 x2) :: []
+ | (x1,_,_) -> (gen1 x1) :: []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: _ -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ Some (y1,Some y2,Some y3)
+ end
+ | x1 :: x2 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (y1,Some y2,None)
+ end
+ | x1 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ Some (y1,None,None)
+ end
+ | _ -> None)
+
+let roo (gen1, parse1) (gen2, parse2) (gen3, parse3) =
+ (function
+ | (x1,Some x2,Some x3) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: []
+ | (x1,Some x2,_) -> (gen1 x1) :: (gen2 x2) :: []
+ | (x1,_,_) -> (gen1 x1) :: []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ Some (y1,Some y2,Some y3)
+ end
+ | x1 :: x2 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (y1,Some y2,None)
+ end
+ | x1 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ Some (y1,None,None)
+ end
+ | _ -> None)
+
+let rooon (gen1, parse1) (gen2, parse2) (gen3, parse3) (gen4, parse4) (genL, parseL) =
+ (function
+ | (x1,Some x2,Some x3,Some x4,l) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: (gen4 x4) :: List.map genL l
+ | (x1,Some x2,Some x3,_,_) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: []
+ | (x1,Some x2,_,_,_) -> (gen1 x1) :: (gen2 x2) :: []
+ | (x1,_,_,_,_) -> (gen1 x1) :: []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: x4 :: l -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ match parse4 x4 with None -> None | Some y4 ->
+ let l' = BatList.filter_map parseL l in
+ if List.length l' <> List.length l then None else
+ Some (y1,Some y2,Some y3,Some y4,l')
+ end
+ | x1 :: x2 :: x3 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ Some (y1,Some y2,Some y3,None,[])
+ end
+ | x1 :: x2 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (y1,Some y2,None,None,[])
+ end
+ | x1 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ Some (y1,None,None,None,[])
+ end
+ | _ -> None)
+
+let roooi (gen1, parse1) (gen2, parse2) (gen3, parse3) (gen4, parse4) =
+ (function
+ | (x1,Some x2,Some x3,Some x4) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: (gen4 x4) :: []
+ | (x1,Some x2,Some x3,_) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: []
+ | (x1,Some x2,_,_) -> (gen1 x1) :: (gen2 x2) :: []
+ | (x1,_,_,_) -> (gen1 x1) :: []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: x4 :: _ -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ match parse4 x4 with None -> None | Some y4 ->
+ Some (y1,Some y2,Some y3,Some y4)
+ end
+ | x1 :: x2 :: x3 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ Some (y1,Some y2,Some y3,None)
+ end
+ | x1 :: x2 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (y1,Some y2,None,None)
+ end
+ | x1 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ Some (y1,None,None,None)
+ end
+ | _ -> None)
+
+let rooo (gen1, parse1) (gen2, parse2) (gen3, parse3) (gen4, parse4) =
+ (function
+ | (x1,Some x2,Some x3,Some x4) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: (gen4 x4) :: []
+ | (x1,Some x2,Some x3,_) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: []
+ | (x1,Some x2,_,_) -> (gen1 x1) :: (gen2 x2) :: []
+ | (x1,_,_,_) -> (gen1 x1) :: []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: x4 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ match parse4 x4 with None -> None | Some y4 ->
+ Some (y1,Some y2,Some y3,Some y4)
+ end
+ | x1 :: x2 :: x3 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ Some (y1,Some y2,Some y3,None)
+ end
+ | x1 :: x2 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (y1,Some y2,None,None)
+ end
+ | x1 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ Some (y1,None,None,None)
+ end
+ | _ -> None)
+
+let rrn (gen1, parse1) (gen2, parse2) (genL, parseL) =
+ (function
+ | (x1,x2,l) -> (gen1 x1) :: (gen2 x2) :: List.map genL l
+ ),
+ (function
+ | x1 :: x2 :: l -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ let l' = BatList.filter_map parseL l in
+ if List.length l' <> List.length l then None else
+ Some (y1,y2,l')
+ end
+ | _ -> None)
+
+let rri (gen1, parse1) (gen2, parse2) =
+ (function
+ | (x1,x2) -> (gen1 x1) :: (gen2 x2) :: []
+ ),
+ (function
+ | x1 :: x2 :: _ -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (y1,y2)
+ end
+ | _ -> None)
+
+let rr (gen1, parse1) (gen2, parse2) =
+ (function
+ | (x1,x2) -> (gen1 x1) :: (gen2 x2) :: []
+ ),
+ (function
+ | x1 :: x2 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (y1,y2)
+ end
+ | _ -> None)
+
+let rron (gen1, parse1) (gen2, parse2) (gen3, parse3) (genL, parseL) =
+ (function
+ | (x1,x2,Some x3,l) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: List.map genL l
+ | (x1,x2,_,_) -> (gen1 x1) :: (gen2 x2) :: []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: l -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ let l' = BatList.filter_map parseL l in
+ if List.length l' <> List.length l then None else
+ Some (y1,y2,Some y3,l')
+ end
+ | x1 :: x2 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (y1,y2,None,[])
+ end
+ | _ -> None)
+
+let rroi (gen1, parse1) (gen2, parse2) (gen3, parse3) =
+ (function
+ | (x1,x2,Some x3) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: []
+ | (x1,x2,_) -> (gen1 x1) :: (gen2 x2) :: []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: _ -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ Some (y1,y2,Some y3)
+ end
+ | x1 :: x2 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (y1,y2,None)
+ end
+ | _ -> None)
+
+let rro (gen1, parse1) (gen2, parse2) (gen3, parse3) =
+ (function
+ | (x1,x2,Some x3) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: []
+ | (x1,x2,_) -> (gen1 x1) :: (gen2 x2) :: []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ Some (y1,y2,Some y3)
+ end
+ | x1 :: x2 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (y1,y2,None)
+ end
+ | _ -> None)
+
+let rroon (gen1, parse1) (gen2, parse2) (gen3, parse3) (gen4, parse4) (genL, parseL) =
+ (function
+ | (x1,x2,Some x3,Some x4,l) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: (gen4 x4) :: List.map genL l
+ | (x1,x2,Some x3,_,_) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: []
+ | (x1,x2,_,_,_) -> (gen1 x1) :: (gen2 x2) :: []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: x4 :: l -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ match parse4 x4 with None -> None | Some y4 ->
+ let l' = BatList.filter_map parseL l in
+ if List.length l' <> List.length l then None else
+ Some (y1,y2,Some y3,Some y4,l')
+ end
+ | x1 :: x2 :: x3 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ Some (y1,y2,Some y3,None,[])
+ end
+ | x1 :: x2 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (y1,y2,None,None,[])
+ end
+ | _ -> None)
+
+let rrooi (gen1, parse1) (gen2, parse2) (gen3, parse3) (gen4, parse4) =
+ (function
+ | (x1,x2,Some x3,Some x4) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: (gen4 x4) :: []
+ | (x1,x2,Some x3,_) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: []
+ | (x1,x2,_,_) -> (gen1 x1) :: (gen2 x2) :: []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: x4 :: _ -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ match parse4 x4 with None -> None | Some y4 ->
+ Some (y1,y2,Some y3,Some y4)
+ end
+ | x1 :: x2 :: x3 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ Some (y1,y2,Some y3,None)
+ end
+ | x1 :: x2 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (y1,y2,None,None)
+ end
+ | _ -> None)
+
+let rroo (gen1, parse1) (gen2, parse2) (gen3, parse3) (gen4, parse4) =
+ (function
+ | (x1,x2,Some x3,Some x4) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: (gen4 x4) :: []
+ | (x1,x2,Some x3,_) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: []
+ | (x1,x2,_,_) -> (gen1 x1) :: (gen2 x2) :: []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: x4 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ match parse4 x4 with None -> None | Some y4 ->
+ Some (y1,y2,Some y3,Some y4)
+ end
+ | x1 :: x2 :: x3 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ Some (y1,y2,Some y3,None)
+ end
+ | x1 :: x2 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ Some (y1,y2,None,None)
+ end
+ | _ -> None)
+
+let rrrn ((gen1, parse1):'a cell) ((gen2, parse2):'b cell) ((gen3, parse3):'c cell) ((genL, parseL):'l cell) =
+ (function
+ | (x1,x2,x3,l) -> ((gen1 x1) :: (gen2 x2) :: (gen3 x3) :: List.map genL l : string list)
+ ),
+ (function
+ | x1 :: x2 :: x3 :: l -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ let l' = BatList.filter_map parseL l in
+ if List.length l' <> List.length l then None else
+ Some (y1,y2,y3,l')
+ end
+ | (_:string list) -> None)
+
+let rrri (gen1, parse1) (gen2, parse2) (gen3, parse3) =
+ (function
+ | (x1,x2,x3) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: _ -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ Some (y1,y2,y3)
+ end
+ | _ -> None)
+
+let rrr (gen1, parse1) (gen2, parse2) (gen3, parse3) =
+ (function
+ | (x1,x2,x3) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ Some (y1,y2,y3)
+ end
+ | _ -> None)
+
+let rrron (gen1, parse1) (gen2, parse2) (gen3, parse3) (gen4, parse4) (genL, parseL) =
+ (function
+ | (x1,x2,x3,Some x4,l) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: (gen4 x4) :: List.map genL l
+ | (x1,x2,x3,_,_) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: x4 :: l -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ match parse4 x4 with None -> None | Some y4 ->
+ let l' = BatList.filter_map parseL l in
+ if List.length l' <> List.length l then None else
+ Some (y1,y2,y3,Some y4,l')
+ end
+ | x1 :: x2 :: x3 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ Some (y1,y2,y3,None,[])
+ end
+ | _ -> None)
+
+let rrroi (gen1, parse1) (gen2, parse2) (gen3, parse3) (gen4, parse4) =
+ (function
+ | (x1,x2,x3,Some x4) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: (gen4 x4) :: []
+ | (x1,x2,x3,_) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: x4 :: _ -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ match parse4 x4 with None -> None | Some y4 ->
+ Some (y1,y2,y3,Some y4)
+ end
+ | x1 :: x2 :: x3 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ Some (y1,y2,y3,None)
+ end
+ | _ -> None)
+
+let rrro (gen1, parse1) (gen2, parse2) (gen3, parse3) (gen4, parse4) =
+ (function
+ | (x1,x2,x3,Some x4) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: (gen4 x4) :: []
+ | (x1,x2,x3,_) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: x4 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ match parse4 x4 with None -> None | Some y4 ->
+ Some (y1,y2,y3,Some y4)
+ end
+ | x1 :: x2 :: x3 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ Some (y1,y2,y3,None)
+ end
+ | _ -> None)
+
+let rrrrn (gen1, parse1) (gen2, parse2) (gen3, parse3) (gen4, parse4) (genL, parseL) =
+ (function
+ | (x1,x2,x3,x4,l) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: (gen4 x4) :: List.map genL l
+ ),
+ (function
+ | x1 :: x2 :: x3 :: x4 :: l -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ match parse4 x4 with None -> None | Some y4 ->
+ let l' = BatList.filter_map parseL l in
+ if List.length l' <> List.length l then None else
+ Some (y1,y2,y3,y4,l')
+ end
+ | _ -> None)
+
+let rrrri (gen1, parse1) (gen2, parse2) (gen3, parse3) (gen4, parse4) =
+ (function
+ | (x1,x2,x3,x4) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: (gen4 x4) :: []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: x4 :: _ -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ match parse4 x4 with None -> None | Some y4 ->
+ Some (y1,y2,y3,y4)
+ end
+ | _ -> None)
+
+let rrrr (gen1, parse1) (gen2, parse2) (gen3, parse3) (gen4, parse4) =
+ (function
+ | (x1,x2,x3,x4) -> (gen1 x1) :: (gen2 x2) :: (gen3 x3) :: (gen4 x4) :: []
+ ),
+ (function
+ | x1 :: x2 :: x3 :: x4 :: [] -> begin
+ match parse1 x1 with None -> None | Some y1 ->
+ match parse2 x2 with None -> None | Some y2 ->
+ match parse3 x3 with None -> None | Some y3 ->
+ match parse4 x4 with None -> None | Some y4 ->
+ Some (y1,y2,y3,y4)
+ end
+ | _ -> None)
+
+(* Generator code (requires some manual adjustments after generation *)
+
+module Gen = struct
+
+ let list_init f n =
+ let rec aux i =
+ if i = n then [] else f i :: aux (i+1)
+ in aux 0
+
+ let nth i = string_of_int (succ i)
+
+ let cell i = "(gen" ^ nth i ^ ", parse" ^ nth i ^ ")"
+
+ let gen r o kind =
+
+ let list = match kind with
+ | `List -> " (genL, parseL)"
+ | `Ignore -> ""
+ | `None -> ""
+ in
+
+ let tail = match kind with
+ | `List -> "List.map genL l"
+ | `Ignore -> "[]"
+ | `None -> "[]"
+ in
+
+ let tail' = match kind with
+ | `List -> "l"
+ | `Ignore -> "_"
+ | `None -> "[]"
+ in
+
+ let suffix = match kind with
+ | `List -> "n"
+ | `Ignore -> "i"
+ | `None -> ""
+ in
+
+ Printf.sprintf "let %s%s%s %s%s =\n (function%s\n),\n(function%s%s)\n"
+ (String.make r 'r')
+ (String.make o 'o')
+ suffix
+ (String.concat " " (list_init cell (r + o)))
+ list
+
+ begin String.concat "" (list_init (fun o' ->
+ let o' = o - o' in
+ Printf.sprintf "\n| (%s%s) -> %s :: %s"
+
+ (String.concat "," (list_init (fun i ->
+ if i < r then "x" ^ nth i else
+ if i < r + o' then "Some x" ^ nth i else "_") (r+o)))
+
+ (if kind = `List then
+ if o <> o' then ",_" else ",l"
+ else "")
+
+ (String.concat " :: " (list_init (fun i ->
+ "(gen" ^ nth i ^ " x" ^ nth i ^ ")" ) (r + o' )))
+
+ (if o <> o' then "[]" else tail)
+
+ ) (o + 1)) end
+
+ begin String.concat "" (list_init (fun o' ->
+ let o' = o - o' in
+ Printf.sprintf "\n| %s :: %s -> begin\n%s%s Some (%s%s)\nend"
+
+ (String.concat " :: " (list_init (fun i ->
+ "x"^nth i) (r + o')))
+
+ (if o <> o' then "[]" else tail')
+
+ (String.concat " " (list_init (fun i ->
+ "match parse" ^ nth i ^ " x" ^ nth i
+ ^ " with None -> None | Some y" ^ nth i ^ " ->\n") (r + o')))
+
+ (if kind = `List then
+ if o <> o' then "" else
+ " let l' = BatList.filter_map parseL l in\nif List.length l' <> List.length l then None else\n"
+ else
+ "")
+
+ (String.concat "," (list_init (fun i ->
+ if i < r then "y" ^ nth i else
+ if i < r + o' then "Some y" ^ nth i else
+ "None") (r + o)))
+
+ (if kind = `List then
+ if o <> o' then ",[]" else ",l'"
+ else "")
+
+ ) (o + 1)) end
+
+ "\n| _ -> None"
+
+ let print () =
+ for r = 0 to 4 do
+ for o = (if r = 0 then 1 else 0) to 4 - r do
+ print_endline (gen r o `List) ;
+ print_endline (gen r o `Ignore) ;
+ print_endline (gen r o `None)
+ done
+ done
+
+
+end
14 src/action_Common.ml
View
@@ -0,0 +1,14 @@
+(* Ohm is © 2012 Victor Nicollet *)
+
+open Util
+open BatPervasives
+
+module BS = BatString
+
+let path_clean path =
+ if BS.is_empty path then path
+ else let path =
+ if BS.ends_with path "/" then BS.rchop path
+ else path
+ in if BS.starts_with path "/" then BS.lchop path
+ else path
86 src/action_Request.ml
View
@@ -0,0 +1,86 @@
+(* Ohm is © 2012 Victor Nicollet *)
+
+open Util
+open BatPervasives
+
+open Action_Common
+
+class type ['server,'args] request = object
+ method server : 'server
+ method path : string
+ method post : [ `JSON of Json_type.t | `POST of (string,string) BatPMap.t ] option
+ method get : string -> string option
+ method args : 'args
+ method cookie : string -> string option
+end
+
+class ['server,'args] nilreq (server:'server) (args:'args) = object
+
+ val server = server
+ method server = server
+
+ val args = args
+ method args = args