Source file userconf.ml

(* Ocsigen
 * http://www.ocsigen.org
 * Module userconf.ml
 * Copyright (C) 2007 Vincent Balat
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published by
 * the Free Software Foundation, with linking exception;
 * either version 2.1 of the License, or (at your option) any later version.
 *
 * This program 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 Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public License
 * along with this program; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 *)

(* Local (users) config files *)

open Lwt.Infix

exception NoConfFile

let section = Lwt_log.Section.make "ocsigen:ext:userconf"

let err_500 =
  Ocsigen_extensions.Ext_stop_site
    (Ocsigen_cookie_map.empty, `Internal_server_error)

let handle_parsing_error {Ocsigen_extensions.request_info ;_} = function
  | Ocsigen_extensions.Error_in_config_file s ->
    Lwt_log.ign_error_f ~section
      "Syntax error in userconf configuration file for url %s: %s"
      (Uri.to_string (Ocsigen_request.uri request_info)) s;
    Lwt.return err_500
  | Ocsigen_extensions.Error_in_user_config_file s ->
    Lwt_log.ign_error_f ~section
      "Unauthorized option in user configuration for url %s: %s"
      (Uri.to_string (Ocsigen_request.uri request_info)) s;
    Lwt.return err_500
  | e ->
    Lwt.fail e

(* Answer returned by userconf when the url matches *)
let subresult new_req user_parse_site conf previous_err req req_state =
  Ocsigen_extensions.Ext_sub_result (fun cookies_to_set _rs ->
    (* XXX why is rs above never used ?? *)
    Lwt.catch
      (fun () ->
         user_parse_site conf cookies_to_set
           (Ocsigen_extensions.Req_not_found (previous_err, new_req))
         >>= fun (answer, cookies) ->
         (* If the request is not satisfied by userconf, the
            changes in configuration (in request_config) are
            preserved for the remainder of the enclosing <site> (in
            the Ext_continue and Ext_found_continue cases below) *)
         let rec aux ((answer, cts) as r) = match answer with
           | Ocsigen_extensions.Ext_sub_result sr ->
             (* XXX Are these the good cookies ?? *)
             sr cookies_to_set req_state
             >>= aux
           | Ocsigen_extensions.Ext_continue_with
               ({Ocsigen_extensions.request_config ;_}, cookies, err) ->
             Lwt.return
               ((Ocsigen_extensions.Ext_continue_with
                   ({req with Ocsigen_extensions.request_config},
                    cookies, err)), cts)
           | Ocsigen_extensions.Ext_found_continue_with r ->
             (* We keep config information outside userconf! *)
             Lwt.return
               (Ocsigen_extensions.Ext_found_continue_with
                  (fun () ->
                     r () >|= fun (r, {Ocsigen_extensions.request_config ;_}) ->
                     r, { req with Ocsigen_extensions.request_config }
                  ), cts)
           | _ ->
             Lwt.return r
         in aux (answer, cookies)
      )
      (fun e ->
         handle_parsing_error req e >>=
         fun answer ->
         Lwt.return (answer, Ocsigen_cookie_map.empty))
  )

let conf_to_xml conf =
  try [Xml.parse_file conf] with
  | Sys_error _ ->
    raise NoConfFile
  | Xml.Error (s, loc) ->
    let begin_char, end_char = Xml.range loc and line = Xml.line loc in
    raise (Ocsigen_extensions.Error_in_config_file
             (Printf.sprintf "%s, line %d, characters %d-%d"
                (Xml.error_msg s)
                line begin_char end_char))

let gen hostpattern sitepath (regexp, conf, url, prefix, localpath) =
  function
  | Ocsigen_extensions.Req_found _ ->
    (* We do not allow setting filters through userconf files right now *)
    Lwt.return Ocsigen_extensions.Ext_do_nothing
  | Ocsigen_extensions.Req_not_found
      (previous_err,
       ({Ocsigen_extensions.request_info ;
         request_config} as req)) as req_state ->
    let path = (Ocsigen_request.sub_path_string request_info) in
    match Ocsigen_lib.Netstring_pcre.string_match regexp path 0 with
    | None -> Lwt.return (Ocsigen_extensions.Ext_next previous_err)
    | Some _ ->
      try
        Lwt_log.ign_info ~section "Using user configuration";
        let conf0 = Ocsigen_extensions.replace_user_dir regexp conf path in
        let uri =
          Uri.of_string
            (Ocsigen_lib.Netstring_pcre.global_replace regexp url path)
        and prefix =
          Ocsigen_lib.Netstring_pcre.global_replace
            regexp prefix path
        and userconf_options = {
          Ocsigen_extensions.localfiles_root =
            Ocsigen_extensions.replace_user_dir regexp localpath path }
        and conf = conf_to_xml conf0 in
        let user_parse_host =
          Ocsigen_extensions.parse_config_item
            (Some userconf_options) hostpattern request_config in
        (* Inside userconf, we create a new virtual site starting
           after [prefix], and use a request modified accordingly*)
        let user_parse_site =
          Ocsigen_extensions.make_parse_config
            (sitepath @ [prefix]) user_parse_host
        and req =
          { req with
            Ocsigen_extensions.request_info =
              Ocsigen_request.update ~uri request_info }
        in
        Lwt.return
          (subresult req user_parse_site conf previous_err req req_state)
      with
      | Ocsigen_extensions.NoSuchUser
      | NoConfFile
      | Unix.Unix_error (Unix.EACCES,_,_)
      | Unix.Unix_error (Unix.ENOENT, _, _) ->
        Lwt.return (Ocsigen_extensions.Ext_next previous_err)
      | e ->
        handle_parsing_error req e

let parse_config _ hostpattern _ path _ _ config_elem =
  let regexp = ref None in
  let conf = ref None in
  let url = ref None in
  let prefix = ref None in
  let localpath = ref None in
  Ocsigen_extensions.(
    Configuration.process_element
      ~in_tag:"host"
      ~other_elements:(fun t _ _ -> raise (Bad_config_tag_for_extension t))
      ~elements:[
        Configuration.element
          ~name:"userconf"
          ~attributes:[
            Configuration.attribute
              ~name:"regexp"
              ~obligatory:true
              (fun s ->
                 let s = Ocsigen_lib.Netstring_pcre.regexp ("^" ^ s ^ "$") in
                 regexp := Some s);
            Configuration.attribute
              ~name:"conf"
              ~obligatory:true
              (fun s ->
                 let s = Ocsigen_extensions.parse_user_dir s in
                 conf := Some s);
            Configuration.attribute
              ~name:"url"
              ~obligatory:true
              (fun s -> url := Some s);
            Configuration.attribute
              ~name:"prefix"
              ~obligatory:true
              (fun s -> prefix := Some s);
            Configuration.attribute
              ~name:"localpath"
              ~obligatory:true
              (fun s ->
                 let s = Ocsigen_extensions.parse_user_dir s in
                 localpath := Some s)
          ]
          ()]
      config_elem
  );
  let info =
    match !regexp, !conf, !url, !prefix, !localpath  with
    | (Some r, Some t, Some u, Some p, Some p') -> (r, t, u, p, p')
    | _ -> Ocsigen_extensions.badconfig "Missing attributes for <userconf>"
  in
  gen hostpattern path info

let () =
  Ocsigen_extensions.register
    ~name:"userconf"
    ~fun_site:parse_config
    ()