Source file extendconfiguration.ml

(* Ocsigen
 * http://www.ocsigen.org
 * Module extendconfiguration.ml
 * Copyright (C) 2008 Boris Yakobowski
 *
 * 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.
 *)

let name = "extendconfiguration"

let bad_config s = raise (Ocsigen_extensions.Error_in_config_file s)

let gen configfun = function
  | Ocsigen_extensions.Req_found _ ->
    Lwt.return Ocsigen_extensions.Ext_do_nothing

  | Ocsigen_extensions.Req_not_found
      (err, ({Ocsigen_extensions.request_config; _} as request)) ->
    Lwt_log.ign_info "Updating configuration";
    let request =
      { request with
        Ocsigen_extensions.request_config =
          configfun request_config }
    in
    Lwt.return
      (Ocsigen_extensions.Ext_continue_with
         (request, Ocsigen_cookie_map.empty, err))

let gather_do_not_serve_files tag =
  let rec aux (regexps, files, extensions) = function
    | [] -> {
        Ocsigen_extensions.do_not_serve_regexps = regexps;
        do_not_serve_files = files;
        do_not_serve_extensions = extensions
      }
    | Xml.Element ("regexp", ["regexp", f], []) :: q ->
      aux (f :: regexps, files, extensions) q
    | Xml.Element ("file", ["file", f], []) :: q ->
      aux (regexps, f :: files, extensions) q
    | Xml.Element ("extension", ["ext", f], []) :: q ->
      aux (regexps, files, f :: extensions) q

    | _ :: _ -> bad_config ("invalid options in tag " ^ tag)
  in
  aux ([], [], [])

exception Bad_regexp of string

let check_regexp_list =
  let hashtbl = Hashtbl.create 17 in
  List.iter @@ fun r ->
  try Hashtbl.find hashtbl r
  with Not_found ->
  try
    ignore (Ocsigen_lib.Netstring_pcre.regexp r);
    Hashtbl.add hashtbl r ()
  with _ -> raise (Bad_regexp r)

let fun_site usermode _ _ _ _ _ = function
  | Xml.Element ("listdirs", ["value", "true"], []) ->
    gen @@ fun config ->
    { config with Ocsigen_extensions.list_directory_content = true }
  | Xml.Element ("listdirs", ["value", "false"], []) ->
    gen @@ fun config ->
    { config with Ocsigen_extensions.list_directory_content = false }
  | Xml.Element ("listdirs" as s, _, _) ->
    Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | Xml.Element ("followsymlinks", ["value", follow_symlinks], []) ->
    let follow_symlinks =
      match follow_symlinks with
      | "never" ->
        `No
      | "always" ->
        (match usermode with
         | None ->
           `Always
         | Some _ ->
           raise
             (Ocsigen_extensions.Error_in_user_config_file
                "Cannot specify value 'always' for option \
                 'followsymlinks' in userconf files"))
      | "ownermatch" ->
        `Owner_match
      | _ ->
        bad_config ("Wrong value \"" ^ follow_symlinks ^
                    "\" for option \"followsymlinks\"")
    in
    gen @@ fun config ->
    { config with Ocsigen_extensions.follow_symlinks }
  | Xml.Element ("followsymlinks" as s, _, _) ->
    Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | Xml.Element ("charset", attrs, exts) ->
    let rec aux charset_assoc = function
      | [] -> charset_assoc
      | Xml.Element
          ("extension", ["ext", extension; "value", charset], []) :: q ->
        aux
          (Ocsigen_charset_mime.update_charset_ext
             charset_assoc extension charset) q
      | Xml.Element
          ("file", ["file", file; "value", charset], []) :: q ->
        aux
          (Ocsigen_charset_mime.update_charset_file
             charset_assoc file charset)
          q
      | Xml.Element
          ("regexp", ["regexp", regexp; "value", charset], []) :: q ->
        (try
           let r = Ocsigen_lib.Netstring_pcre.regexp regexp in
           aux
             (Ocsigen_charset_mime.update_charset_regexp
                charset_assoc r charset)
             q
         with _ -> bad_config "invalid regexp '%s' in <extension regexp ...>")
      | _ :: _ -> bad_config "invalid subtag in option charset"
    in
    gen (fun config ->
      let config = match attrs with
        | ["default", s] ->
          { config with
            Ocsigen_extensions.charset_assoc =
              Ocsigen_charset_mime.set_default_charset
                config.Ocsigen_extensions.charset_assoc s }
        | [] ->
          config
        | _ ->
          bad_config "Only attribute \"default\" is permitted \
                      for option \"charset\""
      in
      { config with
        Ocsigen_extensions.charset_assoc =
          aux config.Ocsigen_extensions.charset_assoc exts })
  | Xml.Element ("contenttype", attrs, exts) ->
    let rec aux mime_assoc = function
      | [] -> mime_assoc
      | Xml.Element
          ("extension", ["ext", extension; "value", mime], []) :: q ->
        aux
          (Ocsigen_charset_mime.update_mime_ext mime_assoc extension mime)
          q
      | Xml.Element
          ("file", ["file", file; "value", mime], []) :: q ->
        aux (Ocsigen_charset_mime.update_mime_file mime_assoc file mime) q
      | Xml.Element
          ("regexp", ["regexp", regexp; "value", mime], []) :: q ->
        (try
           let r = Ocsigen_lib.Netstring_pcre.regexp regexp in
           aux (Ocsigen_charset_mime.update_mime_regexp mime_assoc r mime) q
         with _ -> bad_config "invalid regexp '%s' in <extension regexp ...>")
      | _ :: _ -> bad_config "invalid subtag in option mime"
    in
    gen (fun config ->
      let config = match attrs with
        | ["default", s] ->
          { config with
            Ocsigen_extensions.mime_assoc =
              Ocsigen_charset_mime.set_default_mime
                config.Ocsigen_extensions.mime_assoc s }
        | [] -> config
        | _ -> bad_config "Only attribute \"default\" is permitted \
                           for option \"contenttype\""
      in
      { config with
        Ocsigen_extensions.mime_assoc =
          aux config.Ocsigen_extensions.mime_assoc exts })
  | Xml.Element ("defaultindex", [], l) ->
    let rec aux indexes = function
      | [] -> List.rev indexes
      | Xml.Element
          ("index", [], [Xml.PCData f]) :: q ->
        aux (f :: indexes) q
      | _ :: _ -> bad_config "subtags must be of the form \
                              <index>...</index> \
                              in option defaultindex"
    in
    gen (fun config ->
      { config with
        Ocsigen_extensions.default_directory_index = aux [] l })
  | Xml.Element ("defaultindex" as s, _, _) ->
    Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | Xml.Element ("hidefile", [], l) ->
    let do_not_serve = gather_do_not_serve_files "hidefile" l in
    (try
       check_regexp_list
         do_not_serve.Ocsigen_extensions.do_not_serve_regexps;
       gen (fun config ->
         { config with
           Ocsigen_extensions.do_not_serve_404 =
             Ocsigen_extensions.join_do_not_serve
               do_not_serve
               config.Ocsigen_extensions.do_not_serve_404 })
     with Bad_regexp r ->
       Ocsigen_extensions.badconfig "Invalid regexp %s in %s" r "hidefile")
  | Xml.Element ("hidefile" as s, _, _) ->
    Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | Xml.Element ("forbidfile", [], l) ->
    let do_not_serve = gather_do_not_serve_files "forbidfile" l in
    (try
       check_regexp_list
         do_not_serve.Ocsigen_extensions.do_not_serve_regexps;
       gen (fun config ->
         { config with
           Ocsigen_extensions.do_not_serve_403 =
             Ocsigen_extensions.join_do_not_serve
               do_not_serve config.Ocsigen_extensions.do_not_serve_403
         })
     with Bad_regexp r ->
       Ocsigen_extensions.badconfig "Invalid regexp %s in %s" r "forbidfile")
  | Xml.Element ("forbidfile" as s, _, _) ->
    Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | Xml.Element
      ("uploaddir", [], [Xml.PCData s]) ->
    gen @@ if s = "" then
      fun config -> { config with Ocsigen_extensions.uploaddir = None }
    else
      fun config -> { config with Ocsigen_extensions.uploaddir = Some s }
  | Xml.Element ("uploaddir" as s, _, _) ->
    Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | Xml.Element
      ("maxuploadfilesize" as tag, [], [Xml.PCData s]) ->
    let s =
      try Ocsigen_parseconfig.parse_size_tag "uploaddir" s
      with Ocsigen_config.Config_file_error _ ->
        Ocsigen_extensions.badconfig "Bad syntax for tag %s" tag
    in
    gen @@ fun config ->
    { config with Ocsigen_extensions.maxuploadfilesize = s }
  | Xml.Element ("maxuploadfilesize" as s, _, _) ->
    Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | Xml.Element (t, _, _) ->
    raise (Ocsigen_extensions.Bad_config_tag_for_extension t)
  | _ ->
    raise (Ocsigen_extensions.Error_in_config_file
             "Unexpected data in config file")

let () = Ocsigen_extensions.register ~name ~fun_site ()