(* $Id: nethttpd_services.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
*)
module Debug = struct
let enable = ref false
end
let dlog = Netlog.Debug.mk_dlog "Nethttpd_services" Debug.enable
let dlogr = Netlog.Debug.mk_dlogr "Nethttpd_services" Debug.enable
let () =
Netlog.Debug.register_module "Nethttpd_services" Debug.enable
open Nethttp
open Nethttp.Header
open Nethttpd_types
open Printf
type host =
{ server_pref_name : string option;
server_pref_port : int option;
server_names : (string * int) list;
server_addresses : (Unix.inet_addr * int) list;
}
type 'a host_distributor =
( host * 'a http_service ) list
(* Note: For all objects below we cannot define classes (i.e. "class xy = ..."),
* but we _must_ fall back to ad-hoc objects (i.e. "let xy = object ... end").
* The reason is a subtle typing difference: classes must not have open types,
* but ad-hoc objects can have them. Here, the method [def_term] is usually
* something like [> `Foo], i.e. an _open_ variant. This is not possible with
* classes. We need open variants, however, otherwise one could not put
* several service objects into the same list, i.e. [ service1; service2 ].
*
* Ad-hoc objects are available since O'Caml 3.08. This means this module cannot
* be type-checked in any earlier version of O'Caml, i.e. this is
* "bleeding-edge typing".
*)
let host_distributor (spec : 'a host_distributor) =
object(self)
method name = "host_distributor"
method def_term = `Host_distributor spec
method print fmt =
Format.fprintf fmt "@[<hv 4>host_distributor(";
List.iter
(fun (host,service) ->
Format.fprintf fmt "@,@[<hv 4>host(";
( match host.server_pref_name with
| Some n -> Format.fprintf fmt "@ pref_name(%s)" n
| None -> ()
);
( match host.server_pref_port with
| Some p -> Format.fprintf fmt "@ pref_port(%d)" p
| None -> ()
);
List.iter
(fun (n,p) ->
Format.fprintf fmt "@ name(%s:%d)" n p
)
host.server_names;
List.iter
(fun (addr,p) ->
let n = Unix.string_of_inet_addr addr in
Format.fprintf fmt "@ addr(%s:%d)" n p
)
host.server_addresses;
Format.fprintf fmt "@ ";
service # print fmt;
Format.fprintf fmt "@]@,)";
)
spec;
Format.fprintf fmt "@]@,)"
method process_header (env : extended_environment) =
(* For simplicity, just iterate over spec and take the first matching host
* definition.
*)
let def_matches host =
(* Check server_names first, then server_addresses. Returns (name,port) on
* success, Not_found otherwise
*)
try
let req_name = env # input_header_field "Host" in
let (req_host, req_port_opt) = split_host_port req_name in
let req_host = String.lowercase req_host in
let req_port = match req_port_opt with Some p -> p | None -> 80 in (* CHECK *)
List.find
(fun (n,p) -> (n = "*" || String.lowercase n = req_host) &&
(p = 0 || p = req_port))
host.server_names
with
Not_found ->
( let (req_sockaddr, req_sockport) =
match env # server_socket_addr with
| Unix.ADDR_INET(inet,port) -> (inet,port)
| _ -> failwith "Not an Internet socket" in
if List.exists
(fun (n,p) ->
(n = Unix.inet_addr_any || n = req_sockaddr) &&
(p = 0 || p = req_sockport))
host.server_addresses
then
(Unix.string_of_inet_addr req_sockaddr, req_sockport)
else
raise Not_found
)
in
let rec find_host hosts =
match hosts with
| (host, service) :: hosts' ->
( try (host, service, def_matches host) with Not_found -> find_host hosts' )
| [] ->
raise Not_found
in
try
let (m_host, m_service, (m_name, m_port)) = find_host spec in (* or Not_found *)
(* Finally, we have found the host [m_host] served by [m_service].
* We must now set the virtual names in [env].
*)
let any_name = Unix.string_of_inet_addr Unix.inet_addr_any in
let (sock_addr, sock_port) =
match env # server_socket_addr with
| Unix.ADDR_INET(inet,port) -> (inet,port)
| _ -> failwith "Not an Internet socket" in
let new_server_name =
match m_host.server_pref_name with
| Some n -> n
| None ->
(* No preferred name: Use [m_name] if possible *)
if m_name = "*" || m_name = any_name then
Unix.string_of_inet_addr sock_addr (* fallback *)
else
m_name in
let new_server_port =
match m_host.server_pref_port with
| Some p -> string_of_int p
| None ->
(* No preferred port: Use [m_port] if possible *)
if m_port = 0 then
string_of_int sock_port (* fallback *)
else
string_of_int m_port in
let new_properties =
update_alist
[ "SERVER_NAME", new_server_name;
"SERVER_PORT", new_server_port
]
env#cgi_properties in
let new_env =
new redirected_environment
~properties:new_properties
~in_channel:(env # input_channel) env in
(* Pass control over to the corresponding service: *)
m_service # process_header new_env
with
Not_found ->
`Std_response(`Not_found, None, (Some "Nethttpd: no matching host definition"))
end
let default_host ?pref_name ?pref_port () =
{ server_pref_name = pref_name;
server_pref_port = pref_port;
server_names = [];
server_addresses = [ Unix.inet_addr_any, 0 ]
}
let options_service () =
object(self)
method name = "options_service"
method def_term = `Options_service
method print fmt =
Format.fprintf fmt "options_service()"
method process_header env =
if env # cgi_request_method = "OPTIONS" && env # cgi_request_uri = "*" then
`Static(`Ok, None, "")
else
`Std_response(`Not_found, None, (Some "Nethttpd: This OPTIONS service works only for *"))
end
type 'a uri_distributor =
( string * 'a http_service ) list
module StrMap = Map.Make(String)
type 'leaf uri_tree =
'leaf uri_node StrMap.t
and 'leaf uri_node =
{ leaf : 'leaf option;
tree : 'leaf uri_tree;
}
let rec make_uri_tree ( spec : 'a uri_distributor )
: 'a http_service uri_tree =
match spec with
| (uri, service) :: spec' ->
let uri_list = Neturl.norm_path (Neturl.split_path uri) in
let tree' = make_uri_tree spec' in
if uri_list <> [] then
merged_uri_tree uri_list tree' service
else tree' (* i.e. uri = "" is silently ignored *)
| [] ->
StrMap.empty
and merged_uri_tree l t service = (* merge l into t *)
match l with
| [x] ->
let t_node_at_x =
try StrMap.find x t with Not_found -> { leaf = None; tree = StrMap.empty } in
let new_t_node_at_x =
{ leaf = Some service;
tree = t_node_at_x.tree;
} in
StrMap.add x new_t_node_at_x t (* replaces old binding, if any *)
| x :: l' ->
let t_node_at_x =
try StrMap.find x t with Not_found -> { leaf = None; tree = StrMap.empty } in
let new_t_node_at_x =
{ leaf = t_node_at_x.leaf;
tree = merged_uri_tree l' t_node_at_x.tree service;
} in
StrMap.add x new_t_node_at_x t (* replaces old binding, if any *)
| [] ->
assert false
let rec find_uri_service uri_list uri_tree =
(* Finds the prefix of [uri_list] in [uri_tree] serving the request *)
match uri_list with
| [] ->
raise Not_found
| directory :: uri_list' ->
let node =
try
(* Search ..../<directory>: *)
StrMap.find directory uri_tree (* or Not_found *)
with
Not_found ->
(* Search ..../: (i.e. trailing slash) *)
let node' = StrMap.find "" uri_tree in
if not (StrMap.is_empty node'.tree) then raise Not_found;
node'
in
( match node.leaf with
| Some service ->
(* Try to find a more specific service *)
( try
find_uri_service uri_list' node.tree
with
Not_found -> service
)
| None ->
find_uri_service uri_list' node.tree
)
exception Bad_uri_escaping
let uri_distributor ( spec : 'a uri_distributor ) =
let uri_tree = make_uri_tree spec in
object(self)
method name = "uri_distributor"
method def_term = `Uri_distributor spec
method print fmt =
Format.fprintf fmt "@[<hv 4>uri_distributor(";
List.iter
(fun (uri,service) ->
Format.fprintf fmt "@ @[<hv 4>uri(%s =>@ " uri;
service # print fmt;
Format.fprintf fmt "@]@ )";
)
spec;
Format.fprintf fmt "@]@ )"
method process_header env =
(* Do path normalization, and if there is something to do, redirect: *)
try
let req_path_esc = env # cgi_script_name in
let req_path =
try uripath_decode req_path_esc
with Failure _ -> raise Bad_uri_escaping
in
let req_uri_list = Neturl.split_path req_path in
let req_uri_list_norm = Neturl.norm_path req_uri_list in
let req_uri_norm = Neturl.join_path req_uri_list_norm in
(* Safety checks *)
( match req_uri_list_norm with
| [] ->
(* i.e. "." - but empty URIs are generally forbidden *)
`Std_response(`Not_found, None, (Some "Nethttpd: Non-absolute URI"))
| [ ".." ] ->
(* i.e. URI begins with ".." *)
`Std_response(`Not_found, None, (Some "Nethttpd: Non-absolute URI"))
| [ ""; ".." ] ->
(* i.e. URI begins with "/.." *)
`Std_response(`Not_found, None, (Some "Nethttpd: URI begins with /.."))
| _ ->
(* Everything else is acceptable. Now perform the redirection if
* the URI changed by normalization:
* CHECK: Maybe it is better not to redirect, but to derive a new
* environment.
*)
if req_uri_norm <> req_path then (
let qs = env#cgi_query_string in
let qm_qs = if qs = "" then "" else "?" ^ qs in
let req_uri_esc = uripath_encode req_uri_norm ^ qm_qs in
raise(Redirect_request(req_uri_esc, env # input_header)));
(* Search the URI to match: *)
( match
( try
Some(find_uri_service req_uri_list_norm uri_tree)
with Not_found -> None
)
with
| Some service ->
service # process_header env
| None ->
`Std_response(`Not_found, None, (Some "Nethttpd: No service bound to URI"))
)
)
with
| Bad_uri_escaping ->
`Std_response(`Not_found, None, (Some "Nethttpd: Bad URI escape sequences"))
end
type 'a linear_distributor =
( (extended_environment -> bool) * 'a http_service ) list
let linear_distributor ( spec : 'a linear_distributor ) =
object(self)
method name = "linear_distributor"
method def_term = `Linear_distributor spec
method print fmt =
Format.fprintf fmt "@[<hv 4>linear_distributor(";
List.iter
(fun (_,service) ->
Format.fprintf fmt "@ @[<hv 4>conditional(??? =>@ ";
service # print fmt;
Format.fprintf fmt "@]@ )";
)
spec;
Format.fprintf fmt "@]@ )"
method process_header env =
match
( try
Some (List.find (fun (cond, service) -> cond env) spec)
with Not_found -> None
)
with
| Some(_, service) ->
service # process_header env
| None ->
`Std_response(`Not_found, None, (Some "Nethttpd: No service matches in linear distribution"))
end
type method_filter =
[ `Limit of string list
| `Limit_except of string list
]
type 'a method_distributor =
( method_filter * 'a http_service ) list
let method_distributor ( spec : 'a method_distributor ) =
object(self)
method name = "method_distributor"
method def_term = `Method_distributor spec
method print fmt =
Format.fprintf fmt "@[<hv 4>method_distributor(";
List.iter
(fun (rule,service) ->
Format.fprintf fmt "@ @[<hv 4>method(%s =>@ "
(match rule with
| `Limit l -> "+" ^ String.concat "," l
| `Limit_except l -> "-" ^ String.concat "," l);
service # print fmt;
Format.fprintf fmt "@]@ )";
)
spec;
Format.fprintf fmt "@]@ )"
method process_header env =
let rule_matches =
function
| `Limit l ->
let req_method = env # cgi_request_method in
List.mem req_method l
| `Limit_except l ->
let req_method = env # cgi_request_method in
not(List.mem req_method l)
in
match
( try
Some (List.find (fun (rule, _) -> rule_matches rule) spec)
with Not_found -> None
)
with
| Some(_, service) ->
service # process_header env
| None ->
`Std_response(`Not_found, None, (Some "Nethttpd: Method not bound"))
end
type std_activation_options =
{ stdactv_processing : Netcgi.arg_store option;
stdactv_operating_type : Netcgi.output_type option;
}
type std_activation =
[ `Std_activation of std_activation_options
| `Std_activation_unbuffered
| `Std_activation_buffered
| `Std_activation_tempfile
]
type 'a dynamic_service =
{ dyn_handler : extended_environment -> 'a -> unit;
dyn_activation : extended_environment -> 'a;
dyn_uri : string option;
dyn_translator : string -> string;
dyn_accept_all_conditionals : bool;
} constraint 'a = # Netcgi.cgi_activation
let rec strip_prefix ~prefix l =
match prefix, l with
| [], l -> l
| (p :: prefix'), (x :: l') ->
if p = x then
strip_prefix ~prefix:prefix' l'
else
raise Not_found
| _, [] ->
raise Not_found
let std_activation tag =
match tag with
| `Std_activation opts ->
(fun env ->
let out_type =
match opts.stdactv_operating_type with
| None -> `Direct ""
| Some p -> p in
let arg_store =
match opts.stdactv_processing with
| None -> (fun _ _ _ -> `Automatic)
| Some f -> f in
Netcgi_common.cgi_with_args
(new Netcgi_common.cgi)
(env :> Netcgi.cgi_environment)
out_type
env#input_channel
arg_store
)
| `Std_activation_unbuffered ->
(fun env ->
Netcgi_common.cgi_with_args
(new Netcgi_common.cgi)
(env :> Netcgi.cgi_environment)
(`Direct "")
env#input_channel
(fun _ _ _ -> `Automatic)
)
| `Std_activation_buffered ->
(fun env ->
Netcgi_common.cgi_with_args
(new Netcgi_common.cgi)
(env :> Netcgi.cgi_environment)
Netcgi.buffered_transactional_outtype
env#input_channel
(fun _ _ _ -> `Automatic)
)
| `Std_activation_tempfile ->
(fun env ->
Netcgi_common.cgi_with_args
(new Netcgi_common.cgi)
(env :> Netcgi.cgi_environment)
Netcgi.tempfile_transactional_outtype
env#input_channel
(fun _ _ _ -> `Automatic)
)
class dynamic_out_channel enabled out_ch : Netchannels.out_obj_channel =
(* if enabled is set to false, output is suppressed *)
object(self)
method output s p len =
if !enabled then
out_ch # output s p len
else
len
method flush() =
if !enabled then
out_ch # flush()
method close_out() =
if !enabled then
out_ch # close_out()
method pos_out =
out_ch # pos_out
method really_output s p len =
if !enabled then
out_ch # really_output s p len
method output_char c =
if !enabled then
out_ch # output_char c
method output_string s =
if !enabled then
out_ch # output_string s
method output_byte b =
if !enabled then
out_ch # output_byte b
method output_buffer b =
if !enabled then
out_ch # output_buffer b
method output_channel ?len ch =
if !enabled then
out_ch # output_channel ?len ch
end
class dynamic_env_wrapper (env:extended_environment) properties =
let in_channel = env#input_channel in
let out_enabled = ref true in
let out_channel = new dynamic_out_channel out_enabled env#output_ch in
object(self)
inherit redirected_environment ~in_channel ~properties env as super
method send_output_header() =
(* Check for CGI-type redirection. In this case we have to suppress
any output. (see also below)
*)
( try
let loc = self # output_header_field "Location" in (* or Not_found *)
if loc = "" || loc.[0] <> '/' then raise Not_found;
dlogr (fun () ->
sprintf "env-%d dynamic_env_wrapper suppressing output"
(Oo.id env));
out_enabled := false; (* suppress output *)
with
Not_found ->
super # send_output_header()
)
method output_ch = out_channel
method out_channel = out_channel
end
let dynamic_service_impl spec =
object(self)
method name = "dynamic_service"
method def_term = `Dynamic_service spec
method print fmt =
Format.fprintf fmt "@[<hv 4>dynamic_service(";
( match spec.dyn_uri with
| None -> ()
| Some uri -> Format.fprintf fmt "@ uri(%s)" uri
);
Format.fprintf fmt "@ accept_all_conditionals(%b)" spec.dyn_accept_all_conditionals;
Format.fprintf fmt "@]@ )"
method process_header (env : extended_environment) =
dlogr (fun () ->
sprintf "env-%d process_header dynamic_service"
(Oo.id env));
try
let req_path_esc = env#cgi_script_name in
let _req_path =
try uripath_decode req_path_esc
with Failure _ -> raise Not_found in
let req_method = env # cgi_request_method in
let allowed =
List.map
Netcgi_common.string_of_http_method
(env # config).Netcgi.permitted_http_methods in
if not (List.mem req_method allowed) then (
let h = new Netmime.basic_mime_header [] in
set_allow h allowed;
raise (Standard_response(`Method_not_allowed,Some h,(Some "Nethttpd: Method not allowed for dynamic service")));
);
if not spec.dyn_accept_all_conditionals then (
if env # multiple_input_header_field "If-match" <> [] then
raise(Standard_response(`Precondition_failed,None,None));
if env # multiple_input_header_field "If-unmodified-since" <> [] then
raise(Standard_response(`Precondition_failed,None,None));
);
dlogr (fun () ->
sprintf "env-%d process_header dynamic_service accepts %s %s"
(Oo.id env) req_method req_path_esc);
(`Accept_body(self :> http_service_receiver) : http_service_reaction)
with
| Not_found ->
`Std_response(`Not_found, None,(Some "Nethttpd: Cannot decode request"))
| Standard_response(status,hdr_opt,errmsg_opt) ->
`Std_response(status,hdr_opt,errmsg_opt)
val response_param = None
method process_body env =
dlogr (fun () ->
sprintf "env-%d process_body dynamic_service"
(Oo.id env));
(* Set PATH_INFO and PATH_TRANSLATED: *)
let props =
match spec.dyn_uri with
| Some dyn_uri ->
let req_path_esc = env#cgi_script_name in
let req_path = uripath_decode req_path_esc in
let req_path_list = Neturl.split_path req_path in
let dyn_path_list = Neturl.split_path dyn_uri in
let path_list =
try "" :: (strip_prefix ~prefix:dyn_path_list req_path_list)
with
Not_found -> []
in
let path = Neturl.join_path path_list in
let path_esc = uripath_encode path in
let path_translated = spec.dyn_translator path in
let properties =
update_alist
[ "PATH_INFO", path_esc;
"PATH_TRANSLATED", path_translated;
"SCRIPT_NAME", uripath_encode dyn_uri
]
env#cgi_properties in
properties
| None ->
env#cgi_properties in
let fenv = new dynamic_env_wrapper env props in
let cgi = spec.dyn_activation fenv in
dlogr (fun () ->
sprintf "env-%d process_body dynamic_service cgi=%d fixed_env=%d"
(Oo.id env) (Oo.id cgi) (Oo.id fenv));
(* We cannot set here response_param directly because this object
is globally used by all incoming requests
*)
let self' =
{< response_param = Some (cgi,fenv) >} in
(self' :> http_service_generator)
method generate_response env =
dlogr (fun () ->
sprintf "env-%d generate_response dynamic_service"
(Oo.id env));
match response_param with
| Some (cgi,fenv) ->
dlogr (fun () ->
sprintf "env-%d generate_response dynamic_service calling handler with cgi=%d fixed_env=%d"
(Oo.id env) (Oo.id cgi) (Oo.id fenv));
spec.dyn_handler fenv cgi;
dlogr (fun () ->
sprintf "env-%d generate_response dynamic_service \
back from handler"
(Oo.id env));
(* Check for CGI-type redirection. In this case we have to do
the actual redirection (see also dynamic_env_wrapper)
*)
( try
let loc =
fenv # output_header_field "Location" in (* or Not_found *)
if loc = "" || loc.[0] <> '/' then raise Not_found;
fenv # output_header # set_fields []; (* Reset output *)
raise(Redirect_response(loc, fenv # input_header))
with
Not_found ->
()
)
| _ ->
failwith "Activation object is missing"
end
let dynamic_service spec =
(dynamic_service_impl spec :> 'a http_service)
type file_option =
[ `Enable_gzip
| `Enable_cooked_compression
| `Override_compression_suffixes of (string * string) list
| `Enable_index_file of string list
| `Enable_listings of
extended_environment -> Netcgi.cgi_activation -> file_service -> unit
]
and file_service =
{ file_docroot : string;
file_uri : string;
file_suffix_types : (string * string) list;
file_default_type : string;
file_options : file_option list;
}
let file_translator spec uri =
let rem_slash s =
let s1 =
if s<>"" && s.[0] = '/' then
String.sub s 1 (String.length s - 1)
else
s in
let s2 =
if s1 <> "" && s1.[String.length s1-1] = '/' then
String.sub s1 0 (String.length s1-1)
else
s1 in
s2 in
let concat p1 p2 =
if p2="" then p1 else Filename.concat p1 p2 in
let rec translate pat_l l =
match (pat_l, l) with
| ([], [""]) ->
spec.file_docroot
| ([], path) ->
concat spec.file_docroot (rem_slash(Neturl.join_path path))
| ([""], path) ->
concat spec.file_docroot (rem_slash(Neturl.join_path path))
| (pat_dir :: pat_l', dir :: l') when pat_dir = dir ->
translate pat_l' l'
| _ ->
raise Not_found
in
let uri_list = Neturl.norm_path (Neturl.split_path uri) in
match uri_list with
| [] ->
(* i.e. "." - but empty URIs are generally forbidden *)
raise Not_found
| [ ".." ] ->
(* i.e. URI begins with ".." *)
raise Not_found
| [ ""; ".." ] ->
(* i.e. URI begins with "/.." *)
raise Not_found
| s :: _ when s <> "" ->
(* i.e. URI does not begin with "/" *)
raise Not_found
| _ ->
(* ok, translate that *)
let spec_uri_list = Neturl.norm_path (Neturl.split_path spec.file_uri) in
translate spec_uri_list uri_list
let ext_re = Netstring_str.regexp ".*\\.\\([^.]+\\)$";;
let get_extension s =
match Netstring_str.string_match ext_re s 0 with
| None ->
None
| Some m ->
Some(Netstring_str.matched_group m 1 s)
let merge_byte_ranges st ranges =
(* Merge the byte [ranges] into a single range. Returns [Some (first,last)] if
* the range is satisfiable, else [None].
*)
let size = st.Unix.LargeFile.st_size in
let max_pos = Int64.pred size in
let rec merge ranges =
match ranges with
| (first_pos_opt, last_pos_opt) :: ranges' ->
let (first_pos, last_pos) =
match (first_pos_opt, last_pos_opt) with
| (Some fp, Some lp) -> (fp, lp)
| (Some fp, None) -> (fp, max_pos)
| (None, Some lp) -> (Int64.sub size lp, max_pos)
| (None, None) -> assert false
in
let first_pos' = max 0L (min first_pos max_pos) in
let last_pos' = max 0L (min last_pos max_pos) in
if first_pos' <= last_pos' then (
match merge ranges' with
| None ->
Some(first_pos', last_pos')
| Some(first_pos'', last_pos'') ->
Some(min first_pos' first_pos'', max last_pos' last_pos'')
)
else
(* This range is void, try next range *)
merge ranges'
| [] ->
None
in
merge ranges
let w32_fix_trailing_slash s =
(* background: Win32 dislikes Unix.stat "directory/". It is unclear whether
this function is still required - file_translator is now changed so
that trailing slashes are normally not returned.
*)
if Sys.os_type = "Win32" then (
if s <> "" && s <> "/" && s.[ String.length s - 1 ] = '/' then
s ^ "."
else
s
)
else s
let get_compression_suffixes file_options =
let rec find opts =
match opts with
| `Override_compression_suffixes l :: _ -> l
| _ :: opts' -> find opts'
| [] ->
[ "gz", "gzip";
"bz2", "bzip2";
"Z", "compress"
] in
find file_options
let rec search_cooked_file filename compression_suffixes =
match compression_suffixes with
| [] ->
[ "identity", filename ]
| (suffix, ce) :: suffixes' ->
try
let filename_ext = filename ^ "." ^ suffix in
let fd = Unix.openfile filename_ext [ Unix.O_RDONLY] 0 in
(* or Unix_error *)
Unix.close fd;
(ce, filename_ext) :: search_cooked_file filename suffixes'
with
| Unix.Unix_error(_,_,_) ->
search_cooked_file filename suffixes'
let file_service (spec : file_service) =
object(self)
method name = "file_service"
method def_term = `File_service spec
method print fmt =
Format.fprintf fmt "@[<hv 4>file_service(";
Format.fprintf fmt "@ docroot(%s)" spec.file_docroot;
Format.fprintf fmt "@ uri(%s)" spec.file_uri;
Format.fprintf fmt "@ @[<hv 4>suffix_types(";
List.iter
(fun (suff,t) -> Format.fprintf fmt "@ %s => %s" suff t)
spec.file_suffix_types;
Format.fprintf fmt "@]@ )";
Format.fprintf fmt "@ default_type(%s)" spec.file_default_type;
Format.fprintf fmt "@ @[<hv 4>options(";
List.iter
(function
| `Enable_gzip -> Format.fprintf fmt "@ enable_gzip"
| `Enable_cooked_compression ->
Format.fprintf fmt "@ enable_cooked_compression"
| `Enable_index_file _ -> Format.fprintf fmt "@ enable_index_file"
| `Enable_listings _ -> Format.fprintf fmt "@ enable_listings"
| `Override_compression_suffixes _ ->
Format.fprintf fmt "@ override_compression_suffixes"
)
spec.file_options;
Format.fprintf fmt "@]@ )";
Format.fprintf fmt "@]@ )";
method process_header env =
try
let req_path_esc = env#cgi_script_name in
let req_path =
try uripath_decode req_path_esc with Failure _ -> raise Not_found in
let filename =
file_translator spec req_path in (* or Not_found *)
let s = Unix.LargeFile.stat (w32_fix_trailing_slash filename) in
(* or Unix_error *)
( match s.Unix.LargeFile.st_kind with
| Unix.S_REG ->
self # serve_regular_file env filename s
| Unix.S_DIR ->
self # serve_directory env filename s
| _ ->
(* other types are illegal *)
raise Not_found
)
with
| Not_found ->
`Std_response(`Not_found, None,(Some "Nethttpd: Can neither translate to regular file nor to directory") )
| Unix.Unix_error(Unix.ENOENT,_,_) ->
`Std_response(`Not_found, None, (Some "Nethttpd: No such file or directory"))
| Unix.Unix_error((Unix.EACCES | Unix.EPERM),_,_) ->
`Std_response(`Forbidden, None, (Some "Nethttpd: File access denied"))
| Unix.Unix_error(e,_,_) ->
`Std_response(`Internal_server_error, None, (Some ("Nethttpd: Unix error: " ^ Unix.error_message e)))
| Standard_response(status,hdr_opt,errmsg_opt) ->
if status = `Ok then
`Static(`Ok,hdr_opt,"")
else
`Std_response(status,hdr_opt,errmsg_opt)
method private serve_regular_file env filename s =
(* Regular file: Check if we can open for reading *)
let fd = Unix.openfile filename [Unix.O_RDONLY] 0 in (* or Unix_error *)
Unix.close fd;
(* If OPTIONS: Respond now *)
let req_method = env # cgi_request_method in
if req_method = "OPTIONS" then (
env # set_output_header_field "Accept-ranges" "bytes";
raise(Standard_response(`Ok, None, None));
);
(* Check request method: Only GET and HEAD are supported *)
if req_method <> "GET" && req_method <> "HEAD" then (
let h = new Netmime.basic_mime_header [] in
set_allow h [ "GET"; "HEAD"; "OPTIONS" ];
raise(Standard_response(`Method_not_allowed,Some h,
(Some "Nethttpd: Method not allowed for file"))));
(* Set [Accept-ranges] header: *)
env # set_output_header_field "Accept-ranges" "bytes";
(* Figure out file extension, content encoding (compression type)
and media type
*)
let media_type_of_ext ext =
try List.assoc ext spec.file_suffix_types
with Not_found -> spec.file_default_type in
let compression_suffixes =
get_compression_suffixes spec.file_options in
let ext_opt = get_extension filename in
let content_encoding, media_type =
match ext_opt with
| Some ext when List.mem_assoc ext compression_suffixes ->
let ce = List.assoc ext compression_suffixes in
let filename1 = Filename.chop_extension filename in
let ext1_opt = get_extension filename1 in
( match ext1_opt with
| None -> (ce, spec.file_default_type)
| Some ext1 -> (ce, media_type_of_ext ext1)
)
| Some ext ->
"identity", media_type_of_ext ext
| None ->
"identity", spec.file_default_type in
env # set_output_header_field "Content-type" media_type;
if content_encoding <> "identity" then
env # set_output_header_field "Content-Encoding" content_encoding;
(* Generate the (weak) validator from the file statistics: *)
let etag =
`Weak (sprintf "%d-%Lu-%.0f"
s.Unix.LargeFile.st_ino
s.Unix.LargeFile.st_size
s.Unix.LargeFile.st_mtime) in
set_etag env#output_header etag;
set_last_modified env#output_header s.Unix.LargeFile.st_mtime;
(* Check for conditional and partial GET *)
(* In order of decreasing priority:
* If-Match: If present, we always respond with code 412. This condition
* requires the availablity of strong validators.
* If-Unmodified-Since: If present, we check the dates, and if passing
* the GET will be carried out.
* If-Modified-Since and If-None-Match: The results of the individual
* tests are ORed (accept when either of the tests accepts):
* +--------------+---------------+-----------+
* | If-Mod-Since | If-None-Match | Behaviour |
* +--------------+---------------+-----------+
* | modified | none | accept |
* | unmodified | none | code 304 |
* | modified | match | accept |
* | unmodified | match | code 304 |
* | none | match | code 304 |
* | modified | no match | accept |
* | unmodified | no match | accept |
* | none | no match | accept |
* +--------------+---------------+-----------+
* (my interpretation of 14.26 of RFC 2616)
*
* If accepted, the second question is whether to return the whole
* file or only a fragment:
* If-Range + Range: (only if both headers are present)
* If the condition is fulfilled, return only the range, else the
* whole document.
* Only Range: The range is satisfied whenever possible.
* No Range: Return whole file. `Enable_gzip is only interpreted in this
* case.
*
*)
if env # multiple_input_header_field "If-match" <> [] then (
raise(Standard_response(`Precondition_failed,None,None));
);
( try
let d = get_if_unmodified_since env#input_header in (* or Not_found *)
if s.Unix.LargeFile.st_mtime > d then
raise(Standard_response(`Precondition_failed,None,None));
with
| Not_found -> ()
| Bad_header_field _ -> ()
);
let accept_if_modified, have_if_modified =
try
let d = get_if_modified_since env#input_header in (* or Not_found *)
s.Unix.LargeFile.st_mtime > d, true
with
| Not_found -> false, false
| Bad_header_field _ -> false, false in
let accept_if_none_match, have_if_none_match =
try
let if_etags = get_if_none_match env#input_header in (* or Not_found *)
( match if_etags with
| None -> (* case: If-None-Match: * *)
false, true
| Some l ->
not (List.exists (weak_validator_match etag) l), true
)
with
| Not_found -> false, false
| Bad_header_field _ -> false, false in
if (have_if_modified || have_if_none_match) &&
not (accept_if_modified || accept_if_none_match)
then
raise(Standard_response(`Not_modified,None,None));
(* Now the GET request is accepted! *)
let partial_GET =
try
let ranges = get_range env#input_header in (* or Not_found *)
(* Ok, we can do a partial GET. Now check if this is not needed
* because of If-Range:
*)
( try
match get_if_range env#input_header with (* or Not_found *)
| `Etag e ->
None
(* Because we do not have strong validators *)
| `Date d ->
if s.Unix.LargeFile.st_mtime <= d then
Some ranges
else
None
with
| Not_found -> Some ranges
| Bad_header_field _ -> Some ranges
)
with
| Not_found -> None
| Bad_header_field _ -> None in
(* So either serve partially or fully: *)
( match partial_GET with
| Some(`Bytes ranges) ->
(* Partial GET: We do not support multipart/byteranges. Instead,
* all requested ranges are implicitly merged into a single one.
*)
let eff_range_opt = merge_byte_ranges s ranges in (* TODO *)
( match eff_range_opt with
| Some ((first_pos,last_pos) as eff_range) ->
(* Serve the file fragment: *)
let h = env # output_header in
set_content_range h
(`Bytes(Some eff_range, Some s.Unix.LargeFile.st_size));
let length = Int64.succ(Int64.sub last_pos first_pos) in
`File(`Partial_content, Some h, filename, first_pos, length)
| None ->
(* The range is not satisfiable *)
let h = env # output_header in
set_content_range h (`Bytes(None,
(Some s.Unix.LargeFile.st_size)
));
`Std_response(`Requested_range_not_satisfiable, Some h, (Some "Nethttpd: Requested range is not satisfiable"))
)
| None ->
(* Full GET *)
(* Check whether there is a gzip-encoded complementary file *)
let encodings_and_files =
if (List.mem `Enable_gzip spec.file_options ||
List.mem `Enable_cooked_compression spec.file_options)
then
search_cooked_file filename compression_suffixes
else
[ "identity", filename ] in
let supported_encodings =
List.map fst encodings_and_files in
let encoding = best_encoding env#input_header supported_encodings in
let h = env # output_header in
( match encoding with
| "identity" ->
`File(`Ok, None, filename, 0L, s.Unix.LargeFile.st_size)
| _ ->
let fn = List.assoc encoding encodings_and_files in
let st_gzip = Unix.LargeFile.stat fn in
h # update_field "Content-Encoding" encoding;
`File(`Ok, Some h, fn, 0L, st_gzip.Unix.LargeFile.st_size)
| _ -> assert false
)
)
method private serve_directory env filename s =
let index_files =
(try List.flatten (List.map (function `Enable_index_file l -> l | _ -> [])
spec.file_options)
with Not_found -> []) in
let abs_index_file_opt =
try
Some (List.find
(fun n -> Sys.file_exists(Filename.concat filename n))
index_files)
with
Not_found -> None in
let gen_listings =
try Some(List.find
(fun opt -> match opt with `Enable_listings _ -> true|_ -> false)
spec.file_options)
with
Not_found -> None in
if abs_index_file_opt <> None || gen_listings <> None then (
let req_path_esc = env#cgi_script_name in
let req_path = uripath_decode req_path_esc in
(* If [req_path] does not end with a slash, perform a redirection: *)
if req_path <> "" && req_path.[ String.length req_path - 1 ] <> '/' then (
let h = new Netmime.basic_mime_header
[ "Location",
sprintf "%s://%s%s%s/"
(if env#cgi_https then "https" else "http")
env#cgi_server_name
( match env#cgi_server_port with
| Some p -> ":" ^ string_of_int p
| None -> "")
env#cgi_request_uri ] in
raise(Standard_response(`Found, Some h, None));
)
);
match (abs_index_file_opt, gen_listings) with
| Some name, _ ->
(* Ok, redirect to the file *)
let req_path_esc = Neturl.split_path env#cgi_script_name in
let name_esc = [ uripath_encode name ] in
raise(Redirect_request(Neturl.join_path (req_path_esc @ name_esc),
env # input_header))
| None, Some (`Enable_listings generator) ->
(* If OPTIONS: Respond now *)
let req_method = env # cgi_request_method in
if req_method = "OPTIONS" then (
raise(Standard_response(`Ok, None, None));
);
(* Check request method: Only GET and HEAD are supported *)
let req_method = env # cgi_request_method in
if req_method <> "GET" && req_method <> "HEAD" then (
let h = new Netmime.basic_mime_header [] in
set_allow h [ "GET"; "HEAD" ];
raise (Standard_response(`Method_not_allowed,Some h,(Some "Nethttpd: Method not allowed for directory listing"))));
(* Generate contents: *)
let dyn_spec =
{ dyn_handler = (fun env cgi -> generator env cgi spec);
dyn_activation = std_activation `Std_activation_unbuffered;
dyn_uri = Some "/";
dyn_translator = (fun _ -> filename);
dyn_accept_all_conditionals = false;
} in
let dyn_srv = dynamic_service dyn_spec in
dyn_srv # process_header env
(*
let (listing, listing_hdr) = generator env spec filename in
(* Generate the (weak) validator from the file statistics: *)
let etag =
`Weak (sprintf "%d-%Lu-%.0f"
s.Unix.LargeFile.st_ino
s.Unix.LargeFile.st_size
s.Unix.LargeFile.st_mtime) in
set_etag listing_hdr etag;
(* Refuse If-match and If-unmodified-since: *)
if env # multiple_input_header_field "If-match" <> [] then
raise(Standard_response(`Precondition_failed, None, None));
if env # multiple_input_header_field "If-unmodified-since" <> [] then
raise(Standard_response(`Precondition_failed, None, None));
(* Return contents: *)
`Static(`Ok, Some listing_hdr, listing)
*)
| _ ->
(* Listings are forbidden: *)
`Std_response(`Forbidden, None, (Some "Nethttpd: Access to directories not configured") )
end
let simple_listing ?(hide=[ "\\."; ".*~$" ]) env (cgi :Netcgi.cgi_activation) fs =
let dirname = env # cgi_path_translated in
let col_name = 30 in
let col_mtime = 20 in
let col_size = 10 in
let regexps = List.map (fun re -> Netstring_str.regexp re) hide in
let req_path_esc = env#cgi_path_info in
let req_path = uripath_decode req_path_esc in
let files = Sys.readdir (w32_fix_trailing_slash dirname) in
let xfiles =
Array.map
(fun name ->
if List.exists
(fun re -> Netstring_str.string_match re name 0 <> None) regexps
then
`None
else
try
let st = Unix.LargeFile.stat (Filename.concat dirname name) in
match st.Unix.LargeFile.st_kind with
| Unix.S_REG ->
`Reg(name, st.Unix.LargeFile.st_mtime, st.Unix.LargeFile.st_size)
| Unix.S_DIR ->
`Dir(name, st.Unix.LargeFile.st_mtime)
| _ ->
`None
with
Unix.Unix_error(_,_,_) -> `None
)
files in
let params =
try Netencoding.Url.dest_url_encoded_parameters env#cgi_query_string
with _ -> [] in
let sort_param =
try List.assoc "sort" params with Not_found -> "name" in
let direction_param =
try List.assoc "direction" params with Not_found -> "ascending" in
let direction_factor =
match direction_param with
| "ascending" -> 1
| "descending" -> (-1)
| _ -> 0 in
let rev_direction =
match direction_param with
| "ascending" -> "descending"
| "descending" -> "ascending"
| _ -> "" in
let query_sort_name =
if sort_param = "name" then
"?sort=name&direction=" ^ rev_direction
else
"?sort=name&direction=ascending" in
let query_sort_mtime =
if sort_param = "mtime" then
"?sort=mtime&direction=" ^ rev_direction
else
"?sort=mtime&direction=ascending" in
let query_sort_size =
if sort_param = "size" then
"?sort=size&direction=" ^ rev_direction
else
"?sort=size&direction=ascending" in
let cmp x y =
match (x,y) with
| `None, `None -> 0
| `None, _ -> (-1)
| _, `None -> 1
| `Dir _, `Reg _ -> (-1)
| `Reg _, `Dir _ -> 1
| `Reg(xname,xmtime,xsize), `Reg(yname,ymtime,ysize) ->
direction_factor *
( match sort_param with
| "name" -> compare xname yname
| "mtime" -> compare xmtime ymtime
| "size" -> compare xsize ysize
| _ -> 0
)
| `Dir(xname,xmtime), `Dir(yname,ymtime) ->
direction_factor *
( match sort_param with
| "name" -> compare xname yname
| "mtime" -> compare xmtime ymtime
| _ -> 0
)
in
Array.stable_sort cmp xfiles;
let esc_html =
Netencoding.Html.encode_from_latin1 in
let link_to href n s =
let s' =
if String.length s > n then
String.sub s 0 n
else
s in
sprintf "<a href=\"%s\">%s</a>%s"
(esc_html href)
s'
(String.make (n-String.length s') ' ')
in
let nolink n s =
let s' =
if String.length s > n then
String.sub s 0 n
else
s in
s' ^ (String.make (n-String.length s') ' ')
in
let mkdate f =
Netdate.format ~fmt:"%Y-%m-%d %H:%M" (Netdate.create f) in
let mksize n =
if n >= 1099511627776L then
sprintf "%8.1fT" (Int64.to_float n /. 1099511627776.0)
else
if n >= 1073741824L then
sprintf "%8.1fG" (Int64.to_float n /. 1073741824.0)
else
if n >= 1048576L then
sprintf "%8.1fM" (Int64.to_float n /. 1048576.0)
else
if n >= 1024L then
sprintf "%8.1fk" (Int64.to_float n /. 1024.0)
else
if n >= 0L then
sprintf "%8.1f" (Int64.to_float n)
else
"-"
in
let out = cgi # output # output_string in
cgi # set_header ();
out "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\" ";
out "\"http://www.w3.org/TR/REC-html40/loose.dtd\">\n";
out (sprintf "<html><head><title>Index of %s</title></head>\n" (esc_html req_path));
out "<body bgcolor=\"#ffffff\" text=\"#000000\">\n";
out (sprintf "<h3>Index of %s</h3>\n" (esc_html req_path));
out "<pre>";
out (sprintf " %s %s %s\n\n"
(link_to query_sort_name col_name "Name")
(link_to query_sort_mtime col_mtime "Last Modified")
(link_to query_sort_size col_size "Size"));
if req_path <> "/" then
out (sprintf "[DIR] %s %s %s\n"
(link_to ".." col_name "Parent Directory")
(nolink col_mtime "")
(nolink col_size ""));
Array.iter
(function
| `Reg(name, mtime, size) ->
let mtime_str = mkdate mtime in
let size_str = mksize size in
out (sprintf "[ ] %s %s %s\n"
(link_to name col_name name)
(nolink col_mtime mtime_str)
(nolink col_size size_str));
| `Dir(name, mtime) ->
let mtime_str = mkdate mtime in
out (sprintf "[DIR] %s %s %s\n"
(link_to name col_name (name ^ "/"))
(nolink col_mtime mtime_str)
(nolink col_size "-"))
| `None ->
()
)
xfiles;
out "</pre></body></html>\n";
cgi # output # commit_work()
type ac_by_host_rule =
[ `Allow of string list
| `Deny of string list
]
type 'a ac_by_host = ac_by_host_rule * 'a http_service
let prepare_ac_by_host spec =
let resolve host =
try
[ Unix.inet_addr_of_string host ]
with
| _ ->
( try
let h = Uq_resolver.get_host_by_name host in
Array.to_list h.Unix.h_addr_list
with
| Uq_resolver.Host_not_found _ -> []
)
in
match spec with
| `Allow hosts ->
let ipaddrs = List.flatten (List.map resolve hosts) in
`Allow_ip ipaddrs
| `Deny hosts ->
let ipaddrs = List.flatten (List.map resolve hosts) in
`Deny_ip ipaddrs
let ac_by_host (spec, (srv : 'a http_service)) =
let spec' = prepare_ac_by_host spec in
( object(self)
method name = "ac_by_host"
method def_term = `Ac_by_host (spec,srv)
method print fmt =
Format.fprintf fmt "ac_by_host(...)"
method process_header env =
let addr = env # remote_socket_addr in
let allowed =
match spec' with
| `Allow_ip ipaddrs ->
( match addr with
| Unix.ADDR_INET(ia,_) ->
List.mem ia ipaddrs
| _ ->
true
)
| `Deny_ip ipaddrs ->
( match addr with
| Unix.ADDR_INET(ia,_) ->
not(List.mem ia ipaddrs)
| _ ->
true
)
in
if allowed then
srv # process_header env
else
`Std_response(`Forbidden, None, (Some "Nethttpd: Access denied by host rule"))
end
)
let ws_re = Netstring_str.regexp "[ \r\t\n]+"
let split_ws s =
Netstring_str.split ws_re s
let read_media_types_file fname =
let f = open_in fname in
let l = ref [] in
try
while true do
let line = input_line f in
if line = "" || line.[0] <> '#' then (
let words = split_ws line in
match words with
| [] -> ()
| [ mtype ] -> ()
| mtype :: suffixes ->
l := (List.map (fun s -> (s,mtype)) (List.rev suffixes)) @ !l
)
done;
assert false
with
| End_of_file ->
close_in f;
List.rev !l
| error ->
close_in f;
raise error
;;
