(* $Id$
 *
 *)

(*
 * 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 really_output_string s p len =
    if !enabled then
      out_ch # really_output_string 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_bytes b =
    if !enabled then
      out_ch # output_bytes 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)
	    )
    )

  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
;;
