(* $Id: nethttpd_types.ml 2195 2015-01-01 12:23:39Z gerd $
*
*)
(*
* Copyright 2005 Baretta s.r.l. and Gerd Stolpmann
*
* This file is part of Nethttpd.
*
* Nethttpd is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* Nethttpd 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 General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with WDialog; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
open Nethttp
open Nethttp.Header
open Printf
exception Standard_response of http_status * http_header option * string option
let exn_print_header b hdr =
Buffer.add_string b "[";
let first = ref true in
List.iter
(fun (n,v) ->
if not !first then Buffer.add_string b ", ";
bprintf b "%s: %S" n v;
first := false
)
hdr#fields;
Buffer.add_string b "]"
let () =
Netexn.register_printer
(Standard_response(`Continue, None, None))
(fun e ->
match e with
| Standard_response(status, hdr_opt, err_opt) ->
let b = Buffer.create 200 in
Buffer.add_string b "Nethttpd_types.Standard_response(";
Buffer.add_string b (Nethttp.string_of_http_status status);
Buffer.add_string b ", ";
( match hdr_opt with
| None ->
Buffer.add_string b "None"
| Some hdr ->
Buffer.add_string b "Some ";
exn_print_header b hdr
);
Buffer.add_string b ", ";
( match err_opt with
| None ->
Buffer.add_string b "None"
| Some err ->
bprintf b "Some %S" err
);
Buffer.add_string b ")";
Buffer.contents b
| _ -> assert false
)
type output_state =
[ `Start
| `Sending
| `End
]
let string_of_output_state =
function
| `Start -> "Start"
| `Sending -> "Sending"
| `End -> "End"
class type request_info =
object
method server_socket_addr : Unix.sockaddr
method remote_socket_addr : Unix.sockaddr
method request_method : string
method request_uri : string
method input_header : Nethttp.http_header
method cgi_properties : (string * string) list
method input_body_size : int64
method tls_session_props : Nettls_support.tls_session_props option
end
class type full_info =
object
inherit request_info
method response_status_code : int
method request_body_rejected : bool
method output_header : Nethttp.http_header
method output_body_size : int64
end
class type error_response_params =
object
inherit request_info
method response_status_code : int
method error_message : string
end
class type virtual v_extended_environment =
object
inherit Netcgi.cgi_environment
method virtual server_socket_addr : Unix.sockaddr
method virtual remote_socket_addr : Unix.sockaddr
method cgi_request_uri : string
method log_props : (string * string) list -> unit
method input_channel : Netchannels.in_obj_channel
method input_body_size : int64
method request_body_rejected : bool
method send_file : Unix.file_descr -> int64 -> unit
method output_state : output_state ref
method tls_session_props : Nettls_support.tls_session_props option
end
class type extended_environment =
object
inherit v_extended_environment
method server_socket_addr : Unix.sockaddr
method remote_socket_addr : Unix.sockaddr
end
class virtual empty_environment =
object(self)
val mutable config = Netcgi.default_config
val mutable in_header = new Netmime.basic_mime_header []
val mutable out_header = new Netmime.basic_mime_header []
val mutable properties = []
val mutable in_channel = new Netchannels.input_string ""
val mutable out_channel = new Netchannels.output_null()
val mutable protocol = `Other
val mutable cookies = lazy(assert false)
val mutable tls_session_props =
(None : Nettls_support.tls_session_props option)
val output_state = ref (`Start : output_state)
initializer (
cookies <- lazy(Nethttp.Header.get_cookie_ct self#input_header)
)
method virtual server_socket_addr : Unix.sockaddr
method virtual remote_socket_addr : Unix.sockaddr
method output_state = output_state
method config = config
method cgi_properties = properties
method cgi_property ?default name =
try
List.assoc name properties
with
Not_found ->
( match default with
| None -> raise Not_found
| Some d -> d
)
method cgi_gateway_interface = self # cgi_property ~default:"" "GATEWAY_INTERFACE"
method cgi_server_software = self # cgi_property ~default:"" "SERVER_SOFTWARE"
method cgi_server_name = self # cgi_property ~default:"" "SERVER_NAME"
method cgi_server_protocol = self # cgi_property ~default:"" "SERVER_PROTOCOL"
method cgi_server_port = ( try
Some(int_of_string(self # cgi_property "SERVER_PORT"))
with Not_found -> None )
method cgi_request_method = self # cgi_property ~default:"" "REQUEST_METHOD"
method cgi_path_info = self # cgi_property ~default:"" "PATH_INFO"
method cgi_path_translated = self # cgi_property ~default:"" "PATH_TRANSLATED"
method cgi_script_name = self # cgi_property ~default:"" "SCRIPT_NAME"
method cgi_query_string = self # cgi_property ~default:"" "QUERY_STRING"
method cgi_remote_host = self # cgi_property ~default:"" "REMOTE_HOST"
method cgi_remote_addr = self # cgi_property ~default:"" "REMOTE_ADDR"
method cgi_auth_type = self # cgi_property ~default:"" "AUTH_TYPE"
method cgi_remote_user = self # cgi_property ~default:"" "REMOTE_USER"
method cgi_remote_ident = self # cgi_property ~default:"" "REMOTE_IDENT"
method cgi_https = match self # cgi_property ~default:"" "HTTPS" with
| "" | "off" -> false | "on" -> true
| _ -> failwith "Cannot interpret HTTPS property"
method cgi_request_uri = self # cgi_property ~default:"" "REQUEST_URI"
method protocol = (protocol : Nethttp.protocol)
method send_output_header() = ()
method send_file (fd:Unix.file_descr) (n:int64) = ()
method log_error (s : string) = ()
method log_props (l : (string*string) list) = ()
method input_header = in_header
method output_header = out_header
method set_status ( st : http_status ) =
out_header # update_field "Status" (string_of_int (int_of_http_status st))
method input_body_size = 0L
method request_body_rejected = false
(* ---- The following is copied from Netcgi_env: ---- *)
(* method input_header = in_header *)
method input_header_field ?default name =
try in_header # field name
with Not_found as nf ->
match default with
None -> raise nf
| Some d -> d
method multiple_input_header_field name =
in_header # multiple_field name
method input_header_fields =
in_header # fields
method user_agent =
self # input_header_field ~default:"" "USER-AGENT"
method cookies = Lazy.force cookies
method cookie name =
List.find (fun c -> Netcgi.Cookie.name c = name) self#cookies
method input_channel = in_channel
method input_content_length =
int_of_string (self # input_header_field "CONTENT-LENGTH")
method input_content_type_string =
self # input_header_field ~default:"" "CONTENT-TYPE"
method input_content_type() =
Netmime_string.scan_mime_type_ep (self # input_header_field "CONTENT-TYPE") []
(*
method output_header =
out_header
*)
method output_header_field ?default name =
try out_header # field name
with Not_found as nf ->
match default with
None -> raise nf
| Some d -> d
method multiple_output_header_field name =
out_header # multiple_field name
method output_header_fields =
out_header # fields
method output_ch =
out_channel
method out_channel =
out_channel
method set_output_header_field name value =
out_header # update_field name value
method set_multiple_output_header_field name values =
out_header # update_multiple_field name values
method set_output_header_fields h =
out_header # set_fields h
method tls_session_props =
tls_session_props
end
class redirected_environment
?in_header:new_in_header
?properties:new_properties
?in_channel:(new_in_channel = new Netchannels.input_string "")
(env : extended_environment) =
object(self)
inherit empty_environment
(* Inherits new containers for both input and output *)
initializer (
config <- env # config;
in_header <- ( match new_in_header with
| Some h -> h
| None -> new Netmime.basic_mime_header env#input_header_fields );
properties <- ( match new_properties with
| Some p ->
env#log_props p;
p
| None -> env # cgi_properties );
in_channel <- new_in_channel;
)
(* The following methods are always delegated to [env]: *)
method server_socket_addr = env # server_socket_addr
method remote_socket_addr = env # remote_socket_addr
method protocol = env # protocol
method send_output_header = env # send_output_header
method log_error = env # log_error
method output_header = env # output_header
method output_header_field = env # output_header_field
method multiple_output_header_field = env # multiple_output_header_field
method output_header_fields = env # output_header_fields
method output_ch = env # output_ch
method set_output_header_field = env # set_output_header_field
method set_multiple_output_header_field = env # set_multiple_output_header_field
method set_output_header_fields = env # set_output_header_fields
method set_status = env # set_status
method send_file = env # send_file
method log_props = env # log_props
method input_body_size = 0L
method request_body_rejected = false
method tls_session_props = env # tls_session_props
method output_state = env # output_state
(* The variable is shared! *)
end
class create_full_info
~response_status_code
~request_body_rejected
~output_header
~output_body_size
(info : request_info) : full_info =
object
method server_socket_addr = info#server_socket_addr
method remote_socket_addr = info#remote_socket_addr
method request_method = info#request_method
method request_uri = info#request_uri
method input_header = info#input_header
method cgi_properties = info#cgi_properties
method input_body_size = info#input_body_size
method tls_session_props = info#tls_session_props
method response_status_code = response_status_code
method request_body_rejected = request_body_rejected
method output_header = output_header
method output_body_size = output_body_size
end
let output_static_response (env : #extended_environment) status hdr_opt body =
( match hdr_opt with
| Some hdr ->
env # output_header # set_fields hdr#fields; (* Replaces any existing fields *)
| None -> ()
);
( match status with
| `No_content
| `Reset_content
| `Not_modified -> ()
| _ ->
( try ignore(env # output_header_field "Content-Type")
with Not_found ->
env # set_output_header_field "Content-type" "text/html";
);
);
env # set_output_header_field
"Content-Length" (string_of_int (String.length body));
env # set_status status;
env # send_output_header();
env # output_ch # output_string body;
env # output_ch # close_out();
;;
let rec output_channel_large (f_to : Netchannels.out_obj_channel) f_from length =
if length > 0L then (
let n = min length (Int64.of_int max_int) in
f_to # output_channel ~len:(Int64.to_int n) f_from;
output_channel_large f_to f_from (Int64.sub length n)
)
else
()
(* -- old implementation:
let output_file_response (env : #extended_environment) status hdr_opt filename pos length =
Netchannels.with_in_obj_channel
( let f = open_in_bin filename in (* or Sys_error *)
LargeFile.seek_in f pos;
new Netchannels.input_channel f)
(fun f_ch ->
( match hdr_opt with
| Some hdr ->
env # output_header # set_fields hdr#fields;
(* Replaces any existing fields *)
| None -> ()
);
( match status with
| `No_content
| `Reset_content
| `Not_modified -> ()
| _ ->
( try ignore(env # output_header_field "Content-Type")
with Not_found -> env # set_output_header_field "Content-type" "text/html";
);
);
env # set_output_header_field "Content-Length" (Int64.to_string length);
env # send_output_header();
output_channel_large env # output_ch f_ch length;
env # output_ch # close_out();
)
*)
let output_file_response env status
hdr_opt filename pos length =
let fd = Unix.openfile filename [Unix.O_RDONLY] 0 in
ignore(Unix.LargeFile.lseek fd pos Unix.SEEK_SET);
( match hdr_opt with
| Some hdr ->
env # output_header # set_fields hdr#fields;
(* Replaces any existing fields *)
| None -> ()
);
env # set_output_header_field "Status" (string_of_int (int_of_http_status status));
env # send_file fd length
;;
class type min_config =
object
method config_error_response : error_response_params -> string
method config_log_error : request_info -> string -> unit
end
let output_std_response config (env : #extended_environment)
status hdr_opt msg_opt =
let req_meth = env # cgi_request_method in
let req_uri = env # cgi_request_uri in
let req_hdr = new Netmime.basic_mime_header env#input_header_fields in
let (msg, have_msg) =
match msg_opt with
| Some msg -> (msg,true)
| None -> ("", false) in
let code = int_of_http_status status in
let info =
( object
method server_socket_addr = env#server_socket_addr
method remote_socket_addr = env#remote_socket_addr
method tls_session_props = env#tls_session_props
method request_method = req_meth
method request_uri = req_uri
method input_header = req_hdr
method cgi_properties = env # cgi_properties
method input_body_size = 0L (* don't know *)
method response_status_code = code
method error_message = msg
end
) in
if have_msg then
config # config_log_error (info :> request_info) msg;
let body =
match status with
| `No_content
| `Reset_content
| `Not_modified -> ""
| _ ->
config # config_error_response info in
let hdr_opt' =
match hdr_opt with
| Some h -> Some h
| None -> Some (new Netmime.basic_mime_header []) in
output_static_response env status hdr_opt' body
exception Redirect_request of string * http_header
exception Redirect_response of string * http_header
let () =
Netexn.register_printer
(Redirect_request("", new Netmime.basic_mime_header []))
(fun e ->
match e with
| Redirect_request(url, hdr) ->
let b = Buffer.create 200 in
bprintf b "Nethttpd_types.Redirect_request(%S, " url;
exn_print_header b hdr;
Buffer.add_string b ")";
Buffer.contents b
| _ -> assert false
);
Netexn.register_printer
(Redirect_response("", new Netmime.basic_mime_header []))
(fun e ->
match e with
| Redirect_response(url, hdr) ->
let b = Buffer.create 200 in
bprintf b "Nethttpd_types.Redirect_response(%S, " url;
exn_print_header b hdr;
Buffer.add_string b ")";
Buffer.contents b
| _ -> assert false
)
class type http_service_generator =
object
method generate_response : extended_environment -> unit
end
class type http_service_receiver =
object
method process_body : extended_environment -> http_service_generator
end
type http_service_reaction =
[ `Accept_body of http_service_receiver
| `Reject_body of http_service_generator
| `Static of http_status * http_header option * string
| `File of http_status * http_header option * string * int64 * int64
| `Std_response of http_status * http_header option * string option
]
class type ['a] http_service =
object
method name : string
method def_term :'a
method print : Format.formatter -> unit
method process_header : extended_environment -> http_service_reaction
end
let update_alist updl l =
updl @ (List.filter (fun (x,y) -> not (List.mem_assoc x updl)) l)
