extensions/redirectmod.ml

   1 (* Ocsigen
   2  * http://www.ocsigen.org
   3  * Module redirectmod.ml
   4  * Copyright (C) 2007 Vincent Balat
   5  * CNRS - Université Paris Diderot Paris 7
   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 extension for defining page redirections                          *)
  24 (* in the configuration file                                                 *)
  25 (*****************************************************************************)
  26 (*****************************************************************************)
  27
  28 (* To compile it:
  29 ocamlfind ocamlc  -thread -package netstring,ocsigen -c extensiontemplate.ml
  30
  31 Then load it dynamically from Ocsigen's config file:
  32    <extension module=".../redirectmod.cmo"/>
  33
  34 *)
  35
  36 open Lwt
  37 open Ocsigen_extensions
  38 open Simplexmlparser
  39
  40
  41
  42 (*****************************************************************************)
  43 (* The table of redirections for each virtual server                         *)
  44 type assockind =
  45   | Regexp of Netstring_pcre.regexp * string
  46       * Ocsigen_lib.yesnomaybe (* full url *)
  47       * bool (* temporary *)
  48
  49
  50
  51 (*****************************************************************************)
  52 (** The function that will generate the pages from the request. *)
  53 let gen dir = function
  54   | Ocsigen_extensions.Req_found _ ->
  55       Lwt.return Ocsigen_extensions.Ext_do_nothing
  56   | Ocsigen_extensions.Req_not_found (err, ri) ->
  57       catch
  58         (* Is it a redirection? *)
  59         (fun () ->
  60            Ocsigen_messages.debug2 "--Redirectmod: Is it a redirection?";
  61            let Regexp (regexp, dest, full, temp) = dir in
  62            let redir =
  63              let fi full =
  64                Ocsigen_extensions.find_redirection
  65                  regexp
  66                  full
  67                  dest
  68                  ri.request_info.ri_ssl
  69                  ri.request_info.ri_host
  70                  ri.request_info.ri_server_port
  71                  ri.request_info.ri_get_params_string
  72                  ri.request_info.ri_sub_path_string
  73                  ri.request_info.ri_full_path_string
  74              in
  75              match full with
  76                | Ocsigen_lib.Yes -> fi true
  77                | Ocsigen_lib.No -> fi false
  78                | Ocsigen_lib.Maybe ->
  79                    try fi false
  80                    with Ocsigen_extensions.Not_concerned -> fi true
  81            in
  82            Ocsigen_messages.debug
  83              (fun () ->
  84                 "--Redirectmod: YES! "^
  85                   (if temp then "Temporary " else "Permanent ")^
  86                   "redirection to: "^redir);
  87            let empty_result = Ocsigen_http_frame.empty_result () in
  88            return
  89              (Ext_found
  90                 (fun () ->
  91                    Lwt.return
  92                      {empty_result with
  93                         Ocsigen_http_frame.res_location = Some redir;
  94                         Ocsigen_http_frame.res_code=
  95                          if temp then 302 else 301}))
  96         )
  97         (function
  98            | Ocsigen_extensions.Not_concerned -> return (Ext_next err)
  99            | e -> fail e)
 100
 101
 102
 103
 104 (*****************************************************************************)
 105
 106 let parse_config = function
 107   | Element ("redirect", atts, []) ->
 108       let rec parse_attrs ((r, f, d, temp) as res) = function
 109         | [] -> res
 110         | ("regexp", regexp)::l when r = None -> (* deprecated *)
 111             parse_attrs
 112               (Some (Netstring_pcre.regexp ("^"^regexp^"$")), Ocsigen_lib.Maybe,
 113                d, temp)
 114               l
 115         | ("fullurl", regexp)::l when r = None ->
 116             parse_attrs
 117               (Some (Netstring_pcre.regexp ("^"^regexp^"$")), Ocsigen_lib.Yes,
 118                d, temp)
 119               l
 120         | ("suburl", regexp)::l when r = None ->
 121             parse_attrs
 122               (Some (Netstring_pcre.regexp ("^"^regexp^"$")), Ocsigen_lib.No,
 123                d, temp)
 124               l
 125         | ("dest", dest)::l when d = None ->
 126             parse_attrs
 127               (r, f, Some dest, temp)
 128               l
 129         | ("temporary", "temporary")::l ->
 130             parse_attrs
 131               (r, f, d, false)
 132               l
 133         | _ -> raise (Error_in_config_file "Wrong attribute for <redirect>")
 134         in
 135         let dir =
 136           match parse_attrs (None, Ocsigen_lib.Yes, None, true) atts with
 137           | (None, _, _, _) ->
 138               raise (Error_in_config_file
 139                        "Missing attribute regexp for <redirect>")
 140           | (_, _, None, _) ->
 141               raise (Error_in_config_file
 142                        "Missing attribute dest for <redirect>>")
 143           | (Some r, full, Some d, temp) ->
 144               Regexp (r, d, full, temp)
 145         in
 146         gen dir
 147   | Element ("redirect" as s, _, _) -> badconfig "Bad syntax for tag %s" s
 148
 149   | Element (t, _, _) ->
 150       raise (Bad_config_tag_for_extension t)
 151   | _ -> raise (Error_in_config_file "(redirectmod extension) Bad data")
 152
 153
 154
 155
 156 (*****************************************************************************)
 157 (** Registration of the extension *)
 158 let () = register_extension
 159   ~name:"redirectmod"
 160   ~fun_site:(fun _ _ _ _ -> parse_config)
 161   ~user_fun_site:(fun _ _ _ _ _ -> parse_config)
 162   ()