extensions/userconf.ml

   1 (* Ocsigen
   2  * http://www.ocsigen.org
   3  * Module userconf.ml
   4  * Copyright (C) 2007 Vincent Balat
   5  * Laboratoire PPS - CNRS Université Paris Diderot
   6  *
   7  * This program is free software; you can redistribute it and/or modify
   8  * it under the terms of the GNU Lesser General Public License as published by
   9  * the Free Software Foundation, with linking exception;
  10  * either version 2.1 of the License, or (at your option) any later version.
  11  *
  12  * This program is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU Lesser General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU Lesser General Public License
  18  * along with this program; if not, write to the Free Software
  19  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  20  *)
  21 (*****************************************************************************)
  22 (*****************************************************************************)
  23 (* Ocsigen module to allow local (users) config files                        *)
  24 (*****************************************************************************)
  25 (*****************************************************************************)
  26
  27
  28 open Lwt
  29 open Ocsigen_lib
  30 open Ocsigen_extensions
  31
  32 exception NoConfFile
  33
  34 (*****************************************************************************)
  35
  36 let err_500 =
  37   Ocsigen_extensions.Ext_stop_site (Ocsigen_http_frame.Cookies.empty, 500)
  38
  39
  40 (* Catch invalid userconf files and report an error *)
  41 let handle_parsing_error req = function
  42   | Ocsigen_extensions.Error_in_config_file s ->
  43       Ocsigen_messages.errlog (Printf.sprintf
  44           "Syntax error in userconf configuration file for url %s: %s"
  45         req.request_info.ri_url_string s);
  46       Lwt.return err_500
  47
  48   | Ocsigen_extensions.Error_in_user_config_file s ->
  49       Ocsigen_messages.errlog  (Printf.sprintf
  50           "Unauthorized option in user configuration for url %s: %s"
  51           req.request_info.ri_url_string s);
  52       Lwt.return err_500
  53
  54   | e -> Lwt.fail e
  55
  56
  57 (* Answer returned by userconf when the url matches *)
  58 let subresult new_req user_parse_site conf previous_err req req_state =
  59   Ext_sub_result
  60     (fun awake cookies_to_set rs ->
  61        (* XXX why is rs above never used ?? *)
  62        Lwt.catch
  63          (fun () ->
  64             user_parse_site conf awake cookies_to_set
  65               (Ocsigen_extensions.Req_not_found (previous_err, new_req))
  66             >>= fun (answer, cookies) ->
  67             (* If the request is not satisfied by userconf, the changes
  68                in configuration (in request_config) are preserved for the
  69                remainder of the enclosing <site> (in the Ext_continue
  70                and Ext_found_continue cases below) *)
  71             let rec aux ((answer, cts) as r) = match answer with
  72               | Ext_sub_result sr ->
  73                   (* XXX Are these the good cookies ?? *)
  74                   sr awake cookies_to_set req_state
  75                   >>= aux
  76               | Ext_continue_with (newreq, cookies, err) ->
  77                   Lwt.return
  78                     ((Ext_continue_with
  79                         ({req with request_config = newreq.request_config },
  80                          cookies, err)), cts)
  81               | Ext_found_continue_with r ->
  82                   (* We keep config information outside userconf! *)
  83                   Lwt.return
  84                     (Ext_found_continue_with
  85                        (fun () ->
  86                           r () >>= fun (r, newreq) -> Lwt.return
  87                           (r,
  88                            { req with request_config = newreq.request_config })
  89                        ), cts)
  90               | _ -> Lwt.return r
  91             in aux (answer, cookies)
  92          )
  93          (fun e ->
  94             handle_parsing_error req e >>=
  95             fun answer ->
  96             Lwt.return (answer, Ocsigen_http_frame.Cookies.empty))
  97     )
  98
  99
 100 let conf_to_xml conf =
 101   try Simplexmlparser.xmlparser_file conf
 102   with
 103     | Sys_error _ -> raise NoConfFile
 104     | Simplexmlparser.Xml_parser_error s ->
 105         raise (Ocsigen_extensions.Error_in_config_file s)
 106
 107
 108 let gen hostpattern sitepath (regexp, conf, url, prefix, localpath) = function
 109   | Req_found _ ->
 110       (* We do not allow setting filters through userconf files right now *)
 111       Lwt.return Ext_do_nothing
 112
 113   | Req_not_found (previous_err, req) as req_state->
 114       let path = req.request_info.ri_sub_path_string in
 115       match Netstring_pcre.string_match regexp path 0 with
 116       | None -> Lwt.return (Ext_next previous_err)
 117       | Some _ ->
 118           try
 119             Ocsigen_messages.debug2 "--Userconf: Using user configuration";
 120             let conf = Ocsigen_extensions.replace_user_dir regexp conf path in
 121             let url = Netstring_pcre.global_replace regexp url path
 122             and prefix = Netstring_pcre.global_replace regexp prefix path
 123             and userconf_options = {
 124               Ocsigen_extensions.localfiles_root =
 125                 Ocsigen_extensions.replace_user_dir regexp localpath path }
 126             and conf = conf_to_xml conf
 127             in
 128             let user_parse_host = Ocsigen_extensions.parse_user_site_item
 129               userconf_options hostpattern in
 130             (* Inside userconf, we create a new virtual site starting
 131                after [prefix], and use a request modified accordingly*)
 132             let user_parse_site = Ocsigen_extensions.make_parse_config
 133               (sitepath@[prefix]) user_parse_host
 134             and path =
 135               Ocsigen_lib.remove_slash_at_beginning
 136                 (Ocsigen_lib.remove_dotdot (Neturl.split_path url))
 137             in
 138             let new_req =
 139               { req with request_info =
 140                   { req.request_info with
 141                       ri_sub_path = path; ri_sub_path_string = url}}
 142             in
 143             Lwt.return
 144              (subresult new_req user_parse_site conf previous_err req req_state)
 145
 146           with
 147           | Ocsigen_extensions.NoSuchUser
 148           | NoConfFile
 149           | Unix.Unix_error (Unix.EACCES,_,_)
 150           | Unix.Unix_error (Unix.ENOENT, _, _) ->
 151               Lwt.return (Ocsigen_extensions.Ext_next previous_err)
 152           | e -> handle_parsing_error req e
 153
 154
 155
 156 (*****************************************************************************)
 157 (** Parsing of config file *)
 158 open Simplexmlparser
 159
 160 let parse_config hostpattern path = fun _ _ ->
 161   let rec parse_attrs_local l ((regexp, conf, url, prefix, path) as r) =
 162     match l with
 163     | [] -> r
 164     | ("regexp", s)::l when regexp = None ->
 165         (try parse_attrs_local l
 166            (Some (Netstring_pcre.regexp ("^"^s^"$")), conf, url, prefix, path)
 167          with Failure _ ->
 168            badconfig "Bad regexp '%s' in <userconf regexp=\"...\" />" s)
 169     | ("conf", s)::l when conf = None ->
 170         parse_attrs_local l
 171          (regexp, Some (Ocsigen_extensions.parse_user_dir s), url, prefix, path)
 172     | ("url", s)::l when url = None ->
 173         parse_attrs_local l (regexp, conf, Some s, prefix, path)
 174     | ("prefix", s)::l when prefix = None ->
 175         parse_attrs_local l (regexp, conf, url, Some s, path)
 176     | ("localpath", s) :: l when path = None ->
 177         parse_attrs_local l
 178          (regexp, conf, url, prefix, Some (Ocsigen_extensions.parse_user_dir s))
 179     | (a, _) :: _ ->
 180         badconfig "Wrong or duplicate attribute %s for <userconf>" a
 181   in
 182   function
 183     | Element ("userconf", atts, []) ->
 184         let info =
 185           match parse_attrs_local atts (None, None, None, None, None)  with
 186             | (Some r, Some t, Some u, Some p, Some p') -> (r, t, u, p, p')
 187             | _ -> badconfig "Missing attributes for <userconf>"
 188         in
 189         gen hostpattern path info
 190     | Element ("userconf", _, _ :: _) ->
 191         badconfig "Incorrect (useless) data inside <userconf>"
 192     | Element (t, _, _) -> raise (Bad_config_tag_for_extension t)
 193     | _ -> badconfig "Bad data in conf file"
 194
 195
 196 (*****************************************************************************)
 197 (** extension registration *)
 198 let () = register_extension
 199   ~name:"userconf"
 200   ~fun_site:parse_config
 201   ()