1
(* $Id: nethttpd_services.ml 1063 2006-12-17 20:54:34Z gerd $
6
* Copyright 2005 Baretta s.r.l. and Gerd Stolpmann
8
* This file is part of Nethttpd.
10
* Nethttpd is free software; you can redistribute it and/or modify
11
* it under the terms of the GNU General Public License as published by
12
* the Free Software Foundation; either version 2 of the License, or
13
* (at your option) any later version.
15
* Nethttpd is distributed in the hope that it will be useful,
16
* but WITHOUT ANY WARRANTY; without even the implied warranty of
17
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18
* GNU General Public License for more details.
20
* You should have received a copy of the GNU General Public License
21
* along with WDialog; if not, write to the Free Software
22
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
31
{ server_pref_name : string option;
32
server_pref_port : int option;
33
server_names : (string * int) list;
34
server_addresses : (Unix.inet_addr * int) list;
37
type 'a host_distributor =
38
( host * 'a http_service ) list
41
(* Note: For all objects below we cannot define classes (i.e. "class xy = ..."),
42
* but we _must_ fall back to ad-hoc objects (i.e. "let xy = object ... end").
43
* The reason is a subtle typing difference: classes must not have open types,
44
* but ad-hoc objects can have them. Here, the method [def_term] is usually
45
* something like [> `Foo], i.e. an _open_ variant. This is not possible with
46
* classes. We need open variants, however, otherwise one could not put
47
* several service objects into the same list, i.e. [ service1; service2 ].
49
* Ad-hoc objects are available since O'Caml 3.08. This means this module cannot
50
* be type-checked in any earlier version of O'Caml, i.e. this is
51
* "bleeding-edge typing".
54
let host_distributor (spec : 'a host_distributor) =
56
method name = "host_distributor"
57
method def_term = `Host_distributor spec
59
Format.fprintf fmt "@[<hv 4>host_distributor(";
61
(fun (host,service) ->
62
Format.fprintf fmt "@,@[<hv 4>host(";
63
( match host.server_pref_name with
64
| Some n -> Format.fprintf fmt "@ pref_name(%s)" n
67
( match host.server_pref_port with
68
| Some p -> Format.fprintf fmt "@ pref_port(%d)" p
73
Format.fprintf fmt "@ name(%s:%d)" n p
78
let n = Unix.string_of_inet_addr addr in
79
Format.fprintf fmt "@ addr(%s:%d)" n p
81
host.server_addresses;
82
Format.fprintf fmt "@ ";
84
Format.fprintf fmt "@]@,)";
87
Format.fprintf fmt "@]@,)"
89
method process_header (env : extended_environment) =
90
(* For simplicity, just iterate over spec and take the first matching host
93
let def_matches host =
94
(* Check server_names first, then server_addresses. Returns (name,port) on
95
* success, Not_found otherwise
98
let req_name = env # input_header_field "Host" in
99
let (req_host, req_port_opt) = split_host_port req_name in
100
let req_host = String.lowercase req_host in
101
let req_port = match req_port_opt with Some p -> p | None -> 80 in (* CHECK *)
103
(fun (n,p) -> (n = "*" || String.lowercase n = req_host) &&
104
(p = 0 || p = req_port))
108
( let (req_sockaddr, req_sockport) =
109
match env # server_socket_addr with
110
| Unix.ADDR_INET(inet,port) -> (inet,port)
111
| _ -> failwith "Not an Internet socket" in
114
(n = Unix.inet_addr_any || n = req_sockaddr) &&
115
(p = 0 || p = req_sockport))
116
host.server_addresses
118
(Unix.string_of_inet_addr req_sockaddr, req_sockport)
123
let rec find_host hosts =
125
| (host, service) :: hosts' ->
126
( try (host, service, def_matches host) with Not_found -> find_host hosts' )
131
let (m_host, m_service, (m_name, m_port)) = find_host spec in (* or Not_found *)
132
(* Finally, we have found the host [m_host] served by [m_service].
133
* We must now set the virtual names in [env].
135
let any_name = Unix.string_of_inet_addr Unix.inet_addr_any in
136
let (sock_addr, sock_port) =
137
match env # server_socket_addr with
138
| Unix.ADDR_INET(inet,port) -> (inet,port)
139
| _ -> failwith "Not an Internet socket" in
140
let new_server_name =
141
match m_host.server_pref_name with
144
(* No preferred name: Use [m_name] if possible *)
145
if m_name = "*" || m_name = any_name then
146
Unix.string_of_inet_addr sock_addr (* fallback *)
149
let new_server_port =
150
match m_host.server_pref_port with
151
| Some p -> string_of_int p
153
(* No preferred port: Use [m_port] if possible *)
155
string_of_int sock_port (* fallback *)
157
string_of_int m_port in
160
[ "SERVER_NAME", new_server_name;
161
"SERVER_PORT", new_server_port
163
env#cgi_properties in
165
new redirected_environment
166
~properties:new_properties
167
~in_channel:(env # input_ch) env in
168
(* Pass control over to the corresponding service: *)
169
m_service # process_header new_env
173
`Std_response(`Not_found, None, (Some "Nethttpd: no matching host definition"))
177
let default_host ?pref_name ?pref_port () =
178
{ server_pref_name = pref_name;
179
server_pref_port = pref_port;
181
server_addresses = [ Unix.inet_addr_any, 0 ]
184
let options_service () =
186
method name = "options_service"
187
method def_term = `Options_service
189
Format.fprintf fmt "options_service()"
190
method process_header env =
191
if env # cgi_request_method = "OPTIONS" && env # cgi_request_uri = "*" then
192
`Static(`Ok, None, "")
194
`Std_response(`Not_found, None, (Some "Nethttpd: This OPTIONS service works only for *"))
197
type 'a uri_distributor =
198
( string * 'a http_service ) list
201
module StrMap = Map.Make(String)
203
type 'leaf uri_tree =
204
'leaf uri_node StrMap.t
206
{ leaf : 'leaf option;
207
tree : 'leaf uri_tree;
210
let rec make_uri_tree ( spec : 'a uri_distributor )
211
: 'a http_service uri_tree =
213
| (uri, service) :: spec' ->
214
let uri_list = Neturl.norm_path (Neturl.split_path uri) in
215
let tree' = make_uri_tree spec' in
216
if uri_list <> [] then
217
merged_uri_tree uri_list tree' service
218
else tree' (* i.e. uri = "" is silently ignored *)
222
and merged_uri_tree l t service = (* merge l into t *)
226
try StrMap.find x t with Not_found -> { leaf = None; tree = StrMap.empty } in
227
let new_t_node_at_x =
228
{ leaf = Some service;
229
tree = t_node_at_x.tree;
231
StrMap.add x new_t_node_at_x t (* replaces old binding, if any *)
234
try StrMap.find x t with Not_found -> { leaf = None; tree = StrMap.empty } in
235
let new_t_node_at_x =
236
{ leaf = t_node_at_x.leaf;
237
tree = merged_uri_tree l' t_node_at_x.tree service;
239
StrMap.add x new_t_node_at_x t (* replaces old binding, if any *)
243
let rec find_uri_service uri_list uri_tree =
244
(* Finds the prefix of [uri_list] in [uri_tree] serving the request *)
248
| directory :: uri_list' ->
251
(* Search ..../<directory>: *)
252
StrMap.find directory uri_tree (* or Not_found *)
255
(* Search ..../: (i.e. trailing slash) *)
256
let node' = StrMap.find "" uri_tree in
257
if not (StrMap.is_empty node'.tree) then raise Not_found;
261
( match node.leaf with
263
(* Try to find a more specific service *)
265
find_uri_service uri_list' node.tree
270
find_uri_service uri_list' node.tree
273
exception Bad_uri_escaping
275
let uri_distributor ( spec : 'a uri_distributor ) =
276
let uri_tree = make_uri_tree spec in
278
method name = "uri_distributor"
279
method def_term = `Uri_distributor spec
281
Format.fprintf fmt "@[<hv 4>uri_distributor(";
283
(fun (uri,service) ->
284
Format.fprintf fmt "@ @[<hv 4>uri(%s =>@ " uri;
286
Format.fprintf fmt "@]@ )";
289
Format.fprintf fmt "@]@ )"
291
method process_header env =
292
(* Do path normalization, and if there is something to do, redirect: *)
294
let req_path_esc = env # cgi_script_name in
296
try uripath_decode req_path_esc
297
with Failure _ -> raise Bad_uri_escaping
299
let req_uri_list = Neturl.split_path req_path in
300
let req_uri_list_norm = Neturl.norm_path req_uri_list in
301
let req_uri_norm = Neturl.join_path req_uri_list_norm in
303
( match req_uri_list_norm with
305
(* i.e. "." - but empty URIs are generally forbidden *)
306
`Std_response(`Not_found, None, (Some "Nethttpd: Non-absolute URI"))
308
(* i.e. URI begins with ".." *)
309
`Std_response(`Not_found, None, (Some "Nethttpd: Non-absolute URI"))
311
(* i.e. URI begins with "/.." *)
312
`Std_response(`Not_found, None, (Some "Nethttpd: URI begins with /.."))
314
(* Everything else is acceptable. Now perform the redirection if
315
* the URI changed by normalization:
316
* CHECK: Maybe it is better not to redirect, but to derive a new
319
if req_uri_norm <> req_path then (
320
let req_uri_esc = uripath_encode req_uri_norm in
321
raise(Redirect_request(req_uri_esc, env # input_header)));
322
(* Search the URI to match: *)
325
Some(find_uri_service req_uri_list_norm uri_tree)
326
with Not_found -> None
330
service # process_header env
332
`Std_response(`Not_found, None, (Some "Nethttpd: No service bound to URI"))
336
| Bad_uri_escaping ->
337
`Std_response(`Not_found, None, (Some "Nethttpd: Bad URI escape sequences"))
341
type 'a linear_distributor =
342
( (extended_environment -> bool) * 'a http_service ) list
344
let linear_distributor ( spec : 'a linear_distributor ) =
346
method name = "linear_distributor"
347
method def_term = `Linear_distributor spec
349
Format.fprintf fmt "@[<hv 4>linear_distributor(";
352
Format.fprintf fmt "@ @[<hv 4>conditional(??? =>@ ";
354
Format.fprintf fmt "@]@ )";
357
Format.fprintf fmt "@]@ )"
359
method process_header env =
362
Some (List.find (fun (cond, service) -> cond env) spec)
363
with Not_found -> None
366
| Some(_, service) ->
367
service # process_header env
369
`Std_response(`Not_found, None, (Some "Nethttpd: No service matches in linear distribution"))
373
[ `Limit of string list
374
| `Limit_except of string list
377
type 'a method_distributor =
378
( method_filter * 'a http_service ) list
380
let method_distributor ( spec : 'a method_distributor ) =
382
method name = "method_distributor"
383
method def_term = `Method_distributor spec
385
Format.fprintf fmt "@[<hv 4>method_distributor(";
387
(fun (rule,service) ->
388
Format.fprintf fmt "@ @[<hv 4>method(%s =>@ "
390
| `Limit l -> "+" ^ String.concat "," l
391
| `Limit_except l -> "-" ^ String.concat "," l);
393
Format.fprintf fmt "@]@ )";
396
Format.fprintf fmt "@]@ )"
398
method process_header env =
402
let req_method = env # cgi_request_method in
403
List.mem req_method l
405
let req_method = env # cgi_request_method in
406
not(List.mem req_method l)
410
Some (List.find (fun (rule, _) -> rule_matches rule) spec)
411
with Not_found -> None
414
| Some(_, service) ->
415
service # process_header env
417
`Std_response(`Not_found, None, (Some "Nethttpd: Method not bound"))
421
type std_activation_options =
422
{ stdactv_processing : (string -> Netmime.mime_header -> Netcgi1_compat.Netcgi.argument_processing) option;
423
stdactv_operating_type : Netcgi1_compat.Netcgi.operating_type option;
427
type std_activation =
428
[ `Std_activation of std_activation_options
429
| `Std_activation_unbuffered
430
| `Std_activation_buffered
431
| `Std_activation_tempfile
435
type 'a dynamic_service =
436
{ dyn_handler : extended_environment -> 'a -> unit;
437
dyn_activation : extended_environment -> 'a;
438
dyn_uri : string option;
439
dyn_translator : string -> string;
440
dyn_accept_all_conditionals : bool;
441
} constraint 'a = # Netcgi1_compat.Netcgi_types.cgi_activation
443
let rec strip_prefix ~prefix l =
446
| (p :: prefix'), (x :: l') ->
448
strip_prefix ~prefix:prefix' l'
455
let std_activation tag =
457
| `Std_activation opts ->
459
new Netcgi1_compat.Netcgi.std_activation
460
~env:(env :> Netcgi1_compat.Netcgi_env.cgi_environment)
461
?processing:opts.stdactv_processing
462
?operating_type:opts.stdactv_operating_type
464
| `Std_activation_unbuffered ->
466
new Netcgi1_compat.Netcgi.std_activation
467
~env:(env :> Netcgi1_compat.Netcgi_env.cgi_environment)
468
~operating_type:(`Direct "")
470
| `Std_activation_buffered ->
472
new Netcgi1_compat.Netcgi.std_activation
473
~env:(env :> Netcgi1_compat.Netcgi_env.cgi_environment)
474
~operating_type:Netcgi1_compat.Netcgi.buffered_transactional_optype
476
| `Std_activation_tempfile ->
478
new Netcgi1_compat.Netcgi.std_activation
479
~env:(env :> Netcgi1_compat.Netcgi_env.cgi_environment)
480
~operating_type:Netcgi1_compat.Netcgi.tempfile_transactional_optype
483
let dynamic_service_impl spec =
485
method name = "dynamic_service"
486
method def_term = `Dynamic_service spec
488
Format.fprintf fmt "@[<hv 4>dynamic_service(";
489
( match spec.dyn_uri with
491
| Some uri -> Format.fprintf fmt "@ uri(%s)" uri
493
Format.fprintf fmt "@ accept_all_conditionals(%b)" spec.dyn_accept_all_conditionals;
494
Format.fprintf fmt "@]@ )"
496
method process_header (env : extended_environment) =
498
let req_path_esc = env#cgi_script_name in
500
try uripath_decode req_path_esc
501
with Failure _ -> raise Not_found in
503
let req_method = env # cgi_request_method in
504
let allowed = (env # config).Netcgi1_compat.Netcgi_env.permitted_http_methods in
505
if not (List.mem req_method allowed) then (
506
let h = new Netmime.basic_mime_header [] in
508
raise (Standard_response(`Method_not_allowed,Some h,(Some "Nethttpd: Method not allowed for dynamic service")));
511
if not spec.dyn_accept_all_conditionals then (
512
if env # multiple_input_header_field "If-match" <> [] then
513
raise(Standard_response(`Precondition_failed,None,None));
514
if env # multiple_input_header_field "If-unmodified-since" <> [] then
515
raise(Standard_response(`Precondition_failed,None,None));
518
(`Accept_body(self :> http_service_receiver) : http_service_reaction)
521
`Std_response(`Not_found, None,(Some "Nethttpd: Cannot decode request"))
522
| Standard_response(status,hdr_opt,errmsg_opt) ->
523
`Std_response(status,hdr_opt,errmsg_opt)
525
val mutable activation = None
526
val mutable fixed_env = None
528
method process_body env =
529
(* Set PATH_INFO and PATH_TRANSLATED: *)
531
match spec.dyn_uri with
533
let req_path_esc = env#cgi_script_name in
534
let req_path = uripath_decode req_path_esc in
535
let req_path_list = Neturl.split_path req_path in
536
let dyn_path_list = Neturl.split_path dyn_uri in
538
try "" :: (strip_prefix ~prefix:dyn_path_list req_path_list)
542
let path = Neturl.join_path path_list in
543
let path_esc = uripath_encode path in
544
let path_translated = spec.dyn_translator path in
548
[ "PATH_INFO", path_esc;
549
"PATH_TRANSLATED", path_translated;
550
"SCRIPT_NAME", uripath_encode dyn_uri
552
env#cgi_properties in
554
new redirected_environment
556
~in_channel:(env # input_ch)
562
let cgi = spec.dyn_activation env in
563
activation <- Some cgi;
564
fixed_env <- Some env;
566
(self :> http_service_generator)
568
method generate_response env =
569
match (activation, fixed_env) with
570
| (Some cgi, Some env) ->
571
spec.dyn_handler env cgi;
572
(* Check for CGI-type redirection: *)
574
let loc = env # output_header_field "Location" in (* or Not_found *)
575
if loc <> "" && loc.[0] = '/' then (
576
env # output_header # set_fields []; (* Reset output *)
577
raise(Redirect_response(loc, env # input_header));
581
() (* no redirection *)
584
failwith "Activation object is missing"
587
let dynamic_service spec =
588
(dynamic_service_impl spec :> 'a http_service)
592
| `Enable_index_file of string list
593
| `Enable_listings of
594
extended_environment -> Netcgi1_compat.Netcgi_types.cgi_activation -> file_service -> unit
598
{ file_docroot : string;
600
file_suffix_types : (string * string) list;
601
file_default_type : string;
602
file_options : file_option list;
605
let file_translator spec uri =
607
if s<>"" && s.[0] = '/' then
608
String.sub s 1 (String.length s - 1)
611
let rec translate pat_l l =
612
match (pat_l, l) with
616
Filename.concat spec.file_docroot (rem_slash(Neturl.join_path path))
618
Filename.concat spec.file_docroot (rem_slash(Neturl.join_path path))
619
| (pat_dir :: pat_l', dir :: l') when pat_dir = dir ->
624
let uri_list = Neturl.norm_path (Neturl.split_path uri) in
627
(* i.e. "." - but empty URIs are generally forbidden *)
630
(* i.e. URI begins with ".." *)
633
(* i.e. URI begins with "/.." *)
635
| s :: _ when s <> "" ->
636
(* i.e. URI does not begin with "/" *)
639
(* ok, translate that *)
640
let spec_uri_list = Neturl.norm_path (Neturl.split_path spec.file_uri) in
641
translate spec_uri_list uri_list
643
let ext_re = Netstring_pcre.regexp ".*\\.([^.]+)$";;
645
let get_extension s =
646
match Netstring_pcre.string_match ext_re s 0 with
650
Some(Netstring_pcre.matched_group m 1 s)
652
let merge_byte_ranges st ranges =
653
(* Merge the byte [ranges] into a single range. Returns [Some (first,last)] if
654
* the range is satisfiable, else [None].
656
let size = st.Unix.LargeFile.st_size in
657
let max_pos = Int64.pred size in
658
let rec merge ranges =
660
| (first_pos_opt, last_pos_opt) :: ranges' ->
661
let (first_pos, last_pos) =
662
match (first_pos_opt, last_pos_opt) with
663
| (Some fp, Some lp) -> (fp, lp)
664
| (Some fp, None) -> (fp, max_pos)
665
| (None, Some lp) -> (Int64.sub size lp, max_pos)
666
| (None, None) -> assert false
668
let first_pos' = max 0L (min first_pos max_pos) in
669
let last_pos' = max 0L (min last_pos max_pos) in
670
if first_pos' <= last_pos' then (
671
match merge ranges' with
673
Some(first_pos', last_pos')
674
| Some(first_pos'', last_pos'') ->
675
Some(min first_pos' first_pos'', max last_pos' last_pos'')
678
(* This range is void, try next range *)
685
let file_service (spec : file_service) =
687
method name = "file_service"
688
method def_term = `File_service spec
690
Format.fprintf fmt "@[<hv 4>file_service(";
691
Format.fprintf fmt "@ docroot(%s)" spec.file_docroot;
692
Format.fprintf fmt "@ uri(%s)" spec.file_uri;
693
Format.fprintf fmt "@ @[<hv 4>suffix_types(";
695
(fun (suff,t) -> Format.fprintf fmt "@ %s => %s" suff t)
696
spec.file_suffix_types;
697
Format.fprintf fmt "@]@ )";
698
Format.fprintf fmt "@ default_type(%s)" spec.file_default_type;
699
Format.fprintf fmt "@ @[<hv 4>options(";
702
| `Enable_gzip -> Format.fprintf fmt "@ enable_gzip"
703
| `Enable_index_file _ -> Format.fprintf fmt "@ enable_index_file"
704
| `Enable_listings _ -> Format.fprintf fmt "@ enable_listings"
707
Format.fprintf fmt "@]@ )";
708
Format.fprintf fmt "@]@ )";
710
method process_header env =
712
let req_path_esc = env#cgi_script_name in
714
try uripath_decode req_path_esc with Failure _ -> raise Not_found in
716
file_translator spec req_path in (* or Not_found *)
717
let s = Unix.LargeFile.stat filename in (* or Unix_error *)
718
( match s.Unix.LargeFile.st_kind with
720
self # serve_regular_file env filename s
722
self # serve_directory env filename s
724
(* other types are illegal *)
729
`Std_response(`Not_found, None,(Some "Nethttpd: Can neither translate to regular file nor to directory") )
730
| Unix.Unix_error(Unix.ENOENT,_,_) ->
731
`Std_response(`Not_found, None, (Some "Nethttpd: No such file or directory"))
732
| Unix.Unix_error((Unix.EACCES | Unix.EPERM),_,_) ->
733
`Std_response(`Forbidden, None, (Some "Nethttpd: File access denied"))
734
| Unix.Unix_error(e,_,_) ->
735
`Std_response(`Internal_server_error, None, (Some ("Nethttpd: Unix error: " ^ Unix.error_message e)))
736
| Standard_response(status,hdr_opt,errmsg_opt) ->
738
`Static(`Ok,hdr_opt,"")
740
`Std_response(status,hdr_opt,errmsg_opt)
742
method private serve_regular_file env filename s =
743
(* Regular file: Check if we can open for reading *)
744
let fd = Unix.openfile filename [Unix.O_RDONLY] 0 in (* or Unix_error *)
746
(* If OPTIONS: Respond now *)
747
let req_method = env # cgi_request_method in
748
if req_method = "OPTIONS" then (
749
env # set_output_header_field "Accept-ranges" "bytes";
750
raise(Standard_response(`Ok, None, None));
752
(* Check request method: Only GET and HEAD are supported *)
753
if req_method <> "GET" && req_method <> "HEAD" then (
754
let h = new Netmime.basic_mime_header [] in
755
set_allow h [ "GET"; "HEAD"; "OPTIONS" ];
756
raise (Standard_response(`Method_not_allowed,Some h,(Some "Nethttpd: Method not allowed for file"))));
757
(* Set [Accept-ranges] header: *)
758
env # set_output_header_field "Accept-ranges" "bytes";
759
(* Figure out file extension and media type *)
760
let ext_opt = get_extension filename in
764
( try List.assoc ext spec.file_suffix_types
765
with Not_found -> spec.file_default_type
767
| None -> spec.file_default_type in
768
env # set_output_header_field "Content-type" media_type;
769
(* Generate the (weak) validator from the file statistics: *)
771
`Weak (sprintf "%d-%Lu-%.0f"
772
s.Unix.LargeFile.st_ino
773
s.Unix.LargeFile.st_size
774
s.Unix.LargeFile.st_mtime) in
775
set_etag env#output_header etag;
776
set_last_modified env#output_header s.Unix.LargeFile.st_mtime;
777
(* Check for conditional and partial GET *)
778
(* In order of decreasing priority:
779
* If-Match: If present, we always respond with code 412. This condition
780
* requires the availablity of strong validators.
781
* If-Unmodified-Since: If present, we check the dates, and if passing
782
* the GET will be carried out.
783
* If-Modified-Since and If-None-Match: The results of the individual
784
* tests are ORed (accept when either of the tests accepts):
785
* +--------------+---------------+-----------+
786
* | If-Mod-Since | If-None-Match | Behaviour |
787
* +--------------+---------------+-----------+
788
* | modified | none | accept |
789
* | unmodified | none | code 304 |
790
* | modified | match | accept |
791
* | unmodified | match | code 304 |
792
* | none | match | code 304 |
793
* | modified | no match | accept |
794
* | unmodified | no match | accept |
795
* | none | no match | accept |
796
* +--------------+---------------+-----------+
797
* (my interpretation of 14.26 of RFC 2616)
799
* If accepted, the second question is whether to return the whole
800
* file or only a fragment:
801
* If-Range + Range: (only if both headers are present)
802
* If the condition is fulfilled, return only the range, else the
804
* Only Range: The range is satisfied whenever possible.
805
* No Range: Return whole file. `Enable_gzip is only interpreted in this
809
if env # multiple_input_header_field "If-match" <> [] then (
810
raise(Standard_response(`Precondition_failed,None,None));
813
let d = get_if_unmodified_since env#input_header in (* or Not_found *)
814
if s.Unix.LargeFile.st_mtime > d then
815
raise(Standard_response(`Precondition_failed,None,None));
818
| Bad_header_field _ -> ()
820
let accept_if_modified, have_if_modified =
822
let d = get_if_modified_since env#input_header in (* or Not_found *)
823
s.Unix.LargeFile.st_mtime > d, true
825
| Not_found -> false, false
826
| Bad_header_field _ -> false, false in
827
let accept_if_none_match, have_if_none_match =
829
let if_etags = get_if_none_match env#input_header in (* or Not_found *)
830
( match if_etags with
831
| None -> (* case: If-None-Match: * *)
834
not (List.exists (weak_validator_match etag) l), true
837
| Not_found -> false, false
838
| Bad_header_field _ -> false, false in
839
if (have_if_modified || have_if_none_match) &&
840
not (accept_if_modified || accept_if_none_match)
842
raise(Standard_response(`Not_modified,None,None));
843
(* Now the GET request is accepted! *)
846
let ranges = get_range env#input_header in (* or Not_found *)
847
(* Ok, we can do a partial GET. Now check if this is not needed
848
* because of If-Range:
851
match get_if_range env#input_header with (* or Not_found *)
854
(* Because we do not have strong validators *)
856
if s.Unix.LargeFile.st_mtime <= d then
862
| Not_found -> Some ranges
863
| Bad_header_field _ -> Some ranges
867
| Bad_header_field _ -> None in
868
(* So either serve partially or fully: *)
869
( match partial_GET with
870
| Some(`Bytes ranges) ->
871
(* Partial GET: We do not support multipart/byteranges. Instead,
872
* all requested ranges are implicitly merged into a single one.
874
let eff_range_opt = merge_byte_ranges s ranges in (* TODO *)
875
( match eff_range_opt with
876
| Some ((first_pos,last_pos) as eff_range) ->
877
(* Serve the file fragment: *)
878
let h = env # output_header in
880
(`Bytes(Some eff_range, Some s.Unix.LargeFile.st_size));
881
let length = Int64.succ(Int64.sub last_pos first_pos) in
882
`File(`Partial_content, Some h, filename, first_pos, length)
885
(* The range is not satisfiable *)
886
let h = env # output_header in
887
set_content_range h (`Bytes(None,
888
(Some s.Unix.LargeFile.st_size)
890
`Std_response(`Requested_range_not_satisfiable, Some h, (Some "Nethttpd: Requested range is not satisfiable"))
894
(* Check whether there is a gzip-encoded complementary file *)
895
let filename_gz = filename ^ ".gz" in
898
let fd = Unix.openfile filename_gz [ Unix.O_RDONLY] 0 in
903
| Unix.Unix_error(_,_,_) -> false in
904
let support_encodings =
905
(if support_gzip then ["gzip"] else []) @ ["identity"] in
906
let encoding = best_encoding env#input_header support_encodings in
907
let h = env # output_header in
908
( match encoding with
910
`File(`Ok, None, filename, 0L, s.Unix.LargeFile.st_size)
912
let st_gzip = Unix.LargeFile.stat filename_gz in
913
h # update_field "Content-Encoding" "gzip";
914
`File(`Ok, Some h, filename_gz, 0L, st_gzip.Unix.LargeFile.st_size)
919
method private serve_directory env filename s =
921
(try List.flatten (List.map (function `Enable_index_file l -> l | _ -> [])
923
with Not_found -> []) in
925
let abs_index_file_opt =
928
(fun n -> Sys.file_exists(Filename.concat filename n))
935
(fun opt -> match opt with `Enable_listings _ -> true|_ -> false)
940
if abs_index_file_opt <> None || gen_listings <> None then (
941
let req_path_esc = env#cgi_script_name in
942
let req_path = uripath_decode req_path_esc in
943
(* If [req_path] does not end with a slash, perform a redirection: *)
944
if req_path <> "" && req_path.[ String.length req_path - 1 ] <> '/' then (
945
let h = new Netmime.basic_mime_header
947
sprintf "http://%s%s%s/"
949
( match env#cgi_server_port with
950
| Some p -> ":" ^ string_of_int p
952
env#cgi_request_uri ] in
953
raise(Standard_response(`Found, Some h, None));
957
match (abs_index_file_opt, gen_listings) with
959
(* Ok, redirect to the file *)
960
let req_path_esc = Neturl.split_path env#cgi_script_name in
961
let name_esc = [ uripath_encode name ] in
962
raise(Redirect_request(Neturl.join_path (req_path_esc @ name_esc),
965
| None, Some (`Enable_listings generator) ->
966
(* If OPTIONS: Respond now *)
967
let req_method = env # cgi_request_method in
968
if req_method = "OPTIONS" then (
969
raise(Standard_response(`Ok, None, None));
971
(* Check request method: Only GET and HEAD are supported *)
972
let req_method = env # cgi_request_method in
973
if req_method <> "GET" && req_method <> "HEAD" then (
974
let h = new Netmime.basic_mime_header [] in
975
set_allow h [ "GET"; "HEAD" ];
976
raise (Standard_response(`Method_not_allowed,Some h,(Some "Nethttpd: Method not allowed for directory listing"))));
977
(* Generate contents: *)
979
{ dyn_handler = (fun env cgi -> generator env cgi spec);
980
dyn_activation = std_activation `Std_activation_unbuffered;
982
dyn_translator = (fun _ -> filename);
983
dyn_accept_all_conditionals = false;
985
let dyn_srv = dynamic_service dyn_spec in
986
dyn_srv # process_header env
988
let (listing, listing_hdr) = generator env spec filename in
989
(* Generate the (weak) validator from the file statistics: *)
991
`Weak (sprintf "%d-%Lu-%.0f"
992
s.Unix.LargeFile.st_ino
993
s.Unix.LargeFile.st_size
994
s.Unix.LargeFile.st_mtime) in
995
set_etag listing_hdr etag;
996
(* Refuse If-match and If-unmodified-since: *)
997
if env # multiple_input_header_field "If-match" <> [] then
998
raise(Standard_response(`Precondition_failed, None, None));
999
if env # multiple_input_header_field "If-unmodified-since" <> [] then
1000
raise(Standard_response(`Precondition_failed, None, None));
1001
(* Return contents: *)
1002
`Static(`Ok, Some listing_hdr, listing)
1006
(* Listings are forbidden: *)
1007
`Std_response(`Forbidden, None, (Some "Nethttpd: Access to directories not configured") )
1012
let simple_listing ?(hide=[ "\\."; ".*~$" ]) env (cgi :Netcgi1_compat.Netcgi_types.cgi_activation) fs =
1013
let dirname = env # cgi_path_translated in
1014
let col_name = 30 in
1015
let col_mtime = 20 in
1016
let col_size = 10 in
1017
let regexps = List.map (fun re -> Netstring_pcre.regexp re) hide in
1018
let req_path_esc = env#cgi_path_info in
1019
let req_path = uripath_decode req_path_esc in
1020
let files = Sys.readdir dirname in
1025
(fun re -> Netstring_pcre.string_match re name 0 <> None) regexps
1030
let st = Unix.LargeFile.stat (Filename.concat dirname name) in
1031
match st.Unix.LargeFile.st_kind with
1033
`Reg(name, st.Unix.LargeFile.st_mtime, st.Unix.LargeFile.st_size)
1035
`Dir(name, st.Unix.LargeFile.st_mtime)
1039
Unix.Unix_error(_,_,_) -> `None
1043
try Netencoding.Url.dest_url_encoded_parameters env#cgi_query_string
1046
try List.assoc "sort" params with Not_found -> "name" in
1047
let direction_param =
1048
try List.assoc "direction" params with Not_found -> "ascending" in
1049
let direction_factor =
1050
match direction_param with
1052
| "descending" -> (-1)
1055
match direction_param with
1056
| "ascending" -> "descending"
1057
| "descending" -> "ascending"
1059
let query_sort_name =
1060
if sort_param = "name" then
1061
"?sort=name&direction=" ^ rev_direction
1063
"?sort=name&direction=ascending" in
1064
let query_sort_mtime =
1065
if sort_param = "mtime" then
1066
"?sort=mtime&direction=" ^ rev_direction
1068
"?sort=mtime&direction=ascending" in
1069
let query_sort_size =
1070
if sort_param = "size" then
1071
"?sort=size&direction=" ^ rev_direction
1073
"?sort=size&direction=ascending" in
1079
| `Dir _, `Reg _ -> (-1)
1080
| `Reg _, `Dir _ -> 1
1081
| `Reg(xname,xmtime,xsize), `Reg(yname,ymtime,ysize) ->
1083
( match sort_param with
1084
| "name" -> compare xname yname
1085
| "mtime" -> compare xmtime ymtime
1086
| "size" -> compare xsize ysize
1089
| `Dir(xname,xmtime), `Dir(yname,ymtime) ->
1091
( match sort_param with
1092
| "name" -> compare xname yname
1093
| "mtime" -> compare xmtime ymtime
1097
Array.stable_sort cmp xfiles;
1100
Netencoding.Html.encode_from_latin1 in
1102
let link_to href n s =
1104
if String.length s > n then
1108
sprintf "<a href=\"%s\">%s</a>%s"
1111
(String.make (n-String.length s') ' ')
1116
if String.length s > n then
1120
s' ^ (String.make (n-String.length s') ' ')
1124
Netdate.format ~fmt:"%Y-%m-%d %H:%M" (Netdate.create f) in
1127
if n >= 1099511627776L then
1128
sprintf "%8.1fT" (Int64.to_float n /. 1099511627776.0)
1130
if n >= 1073741824L then
1131
sprintf "%8.1fG" (Int64.to_float n /. 1073741824.0)
1133
if n >= 1048576L then
1134
sprintf "%8.1fM" (Int64.to_float n /. 1048576.0)
1137
sprintf "%8.1fk" (Int64.to_float n /. 1024.0)
1140
sprintf "%8.1f" (Int64.to_float n)
1145
let out = cgi # output # output_string in
1146
cgi # set_header ();
1147
out "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.0 Transitional//EN\" ";
1148
out "\"http://www.w3.org/TR/REC-html40/loose.dtd\">\n";
1149
out (sprintf "<html><head><title>Index of %s</title></head>\n" (esc_html req_path));
1150
out "<body bgcolor=\"#ffffff\" text=\"#000000\">\n";
1151
out (sprintf "<h3>Index of %s</h3>\n" (esc_html req_path));
1153
out (sprintf " %s %s %s\n\n"
1154
(link_to query_sort_name col_name "Name")
1155
(link_to query_sort_mtime col_mtime "Last Modified")
1156
(link_to query_sort_size col_size "Size"));
1157
if req_path <> "/" then
1158
out (sprintf "[DIR] %s %s %s\n"
1159
(link_to ".." col_name "Parent Directory")
1160
(nolink col_mtime "")
1161
(nolink col_size ""));
1164
| `Reg(name, mtime, size) ->
1165
let mtime_str = mkdate mtime in
1166
let size_str = mksize size in
1167
out (sprintf "[ ] %s %s %s\n"
1168
(link_to name col_name name)
1169
(nolink col_mtime mtime_str)
1170
(nolink col_size size_str));
1171
| `Dir(name, mtime) ->
1172
let mtime_str = mkdate mtime in
1173
out (sprintf "[DIR] %s %s %s\n"
1174
(link_to name col_name (name ^ "/"))
1175
(nolink col_mtime mtime_str)
1176
(nolink col_size "-"))
1181
out "</pre></body></html>\n";
1182
cgi # output # commit_work()
1185
type ac_by_host_rule =
1186
[ `Allow of string list
1187
| `Deny of string list
1190
type 'a ac_by_host = ac_by_host_rule * 'a http_service
1192
let prepare_ac_by_host spec =
1195
[ Unix.inet_addr_of_string host ]
1199
let h = Unix.gethostbyname host in
1200
Array.to_list h.Unix.h_addr_list
1208
let ipaddrs = List.flatten (List.map resolve hosts) in
1211
let ipaddrs = List.flatten (List.map resolve hosts) in
1214
let ac_by_host (spec, (srv : 'a http_service)) =
1215
let spec' = prepare_ac_by_host spec in
1217
method name = "ac_by_host"
1218
method def_term = `Ac_by_host (spec,srv)
1220
Format.fprintf fmt "ac_by_host(...)"
1221
method process_header env =
1222
let addr = env # remote_socket_addr in
1225
| `Allow_ip ipaddrs ->
1227
| Unix.ADDR_INET(ia,_) ->
1232
| `Deny_ip ipaddrs ->
1234
| Unix.ADDR_INET(ia,_) ->
1235
not(List.mem ia ipaddrs)
1241
srv # process_header env
1243
`Std_response(`Forbidden, None, (Some "Nethttpd: Access denied by host rule"))
1248
let ws_re = Pcre.regexp "[ \r\t\n]+"
1251
Netstring_pcre.split ws_re s
1253
let read_media_types_file fname =
1254
let f = open_in fname in
1258
let line = input_line f in
1259
if line = "" || line.[0] <> '#' then (
1260
let words = split_ws line in
1264
| mtype :: suffixes ->
1265
l := (List.map (fun s -> (s,mtype)) (List.rev suffixes)) @ !l
added
removed
src/nethttpd-for-netcgi1/nethttpd_services.ml
