extensions/accesscontrol.ml

   1 (* Ocsigen
   2  * http://www.ocsigen.org
   3  * Module accesscontrol.ml
   4  * Copyright (C) 2007 Vincent Balat, Stéphane Glondu
   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 (** Filtering requests in the configuration file *)
  23
  24 (*
  25
  26 Then load it dynamically from Ocsigen's config file:
  27    <extension module=".../accesscontrol.cmo"/>
  28
  29 *)
  30
  31 open Printf
  32 open Lwt
  33 open Ocsigen_extensions
  34 open Simplexmlparser
  35 open Ocsigen_http_frame
  36
  37
  38
  39 (*****************************************************************************)
  40 (* Parsing a condition *)
  41
  42 let rec parse_condition = function
  43
  44     | Element ("ip", ["value", s], []) ->
  45         let ip_with_mask =
  46           try
  47             Ocsigen_lib.parse_ip s
  48           with Failure _ ->
  49             badconfig "Bad ip/netmask [%s] in <ip> condition" s
  50         in
  51         (fun ri ->
  52            let r =
  53              Ocsigen_lib.match_ip ip_with_mask
  54                (Lazy.force ri.ri_remote_ip_parsed)
  55            in
  56            if r then
  57              Ocsigen_messages.debug2 (sprintf "--Access control (ip): %s matches %s" ri.ri_remote_ip s)
  58            else
  59              Ocsigen_messages.debug2 (sprintf "--Access control (ip): %s does not match %s" ri.ri_remote_ip s);
  60            r)
  61     | Element ("ip" as s, _, _) -> badconfig "Bad syntax for tag %s" s
  62
  63     | Element ("port", ["value", s], []) ->
  64         let port =
  65           try
  66             int_of_string s
  67           with Failure _ ->
  68             badconfig "Bad port [%s] in <port> condition" s
  69         in
  70         (fun ri ->
  71            let r = ri.ri_server_port = port in
  72            if r then
  73              Ocsigen_messages.debug2
  74                (sprintf "--Access control (port): %d accepted" port)
  75            else
  76              Ocsigen_messages.debug2
  77                (sprintf "--Access control (port): %d not accepted (%d expected)" ri.ri_server_port port);
  78            r)
  79     | Element ("port" as s, _, _) -> badconfig "Bad syntax for tag %s" s
  80
  81     | Element ("ssl", [], []) ->
  82         (fun ri ->
  83            let r = ri.ri_ssl in
  84            if r then
  85              Ocsigen_messages.debug2 "--Access control (ssl): accepted"
  86            else
  87              Ocsigen_messages.debug2 "--Access control (ssl): not accepted";
  88            r)
  89     | Element ("ssl" as s, _, _) -> badconfig "Bad syntax for tag %s" s
  90
  91     | Element ("header", ["name", name; "regexp", reg], []) ->
  92         let regexp =
  93           try
  94             Netstring_pcre.regexp ("^"^reg^"$")
  95           with Failure _ ->
  96             badconfig "Bad regular expression [%s] in <header> condition" reg
  97         in
  98         (fun ri ->
  99            let r =
 100              List.exists
 101                (fun a ->
 102                   let r = Netstring_pcre.string_match regexp a 0 <> None in
 103                   if r then Ocsigen_messages.debug2 (sprintf "--Access control (header): header %s matches \"%s\"" name reg);
 104                   r)
 105                (Http_headers.find_all
 106                   (Http_headers.name name)
 107                   ri.ri_http_frame.Ocsigen_http_frame.frame_header.Ocsigen_http_frame.Http_header.headers)
 108            in
 109            if not r then Ocsigen_messages.debug2 (sprintf "--Access control (header): header %s does not match \"%s\"" name reg);
 110            r)
 111     | Element ("header" as s, _, _) -> badconfig "Bad syntax for tag %s" s
 112
 113     | Element ("method", ["value", s], []) ->
 114         let meth =
 115           try
 116             Framepp.method_of_string s
 117           with Failure _ ->
 118             badconfig "Bad method [%s] in <method> condition" s
 119         in
 120         (fun ri ->
 121            let r = meth = ri.ri_method in
 122            if r then Ocsigen_messages.debug
 123              (fun () -> sprintf "--Access control (method): %s matches %s" (Framepp.string_of_method ri.ri_method) s)
 124            else Ocsigen_messages.debug
 125              (fun () -> sprintf "--Access control (method): %s does not match %s" (Framepp.string_of_method ri.ri_method) s);
 126            r)
 127     | Element ("method" as s, _, _) -> badconfig "Bad syntax for tag %s" s
 128
 129     | Element ("protocol", ["value", s], []) ->
 130         let pr =
 131           try
 132             Framepp.proto_of_string s
 133           with Failure _ ->
 134             badconfig "Bad protocol [%s] in <protocol> condition" s
 135         in
 136         (fun ri ->
 137            let r = pr = ri.ri_protocol in
 138            if r then Ocsigen_messages.debug
 139              (fun () -> sprintf "--Access control (protocol): %s matches %s" (Framepp.string_of_proto ri.ri_protocol) s)
 140            else Ocsigen_messages.debug
 141              (fun () -> sprintf "--Access control (protocol): %s does not match %s" (Framepp.string_of_proto ri.ri_protocol) s);
 142            r)
 143     | Element ("protocol" as s, _, _) -> badconfig "Bad syntax for tag %s" s
 144
 145     | Element ("path", ["regexp", s], []) ->
 146         let regexp =
 147           try
 148             Netstring_pcre.regexp ("^"^s^"$")
 149           with Failure _ ->
 150             badconfig "Bad regular expression [%s] in <path> condition" s
 151         in
 152         (fun ri ->
 153            let r =
 154              Netstring_pcre.string_match
 155                regexp ri.ri_sub_path_string 0 <> None
 156            in
 157            if r then Ocsigen_messages.debug
 158              (fun () -> sprintf "--Access control (path): \"%s\" matches \"%s\"" ri.ri_sub_path_string s)
 159            else Ocsigen_messages.debug
 160                (fun () -> sprintf "--Access control (path): \"%s\" does not match \"%s\"" ri.ri_sub_path_string s);
 161            r)
 162     | Element ("path" as s, _, _) -> badconfig "Bad syntax for tag %s" s
 163
 164     | Element ("and", [], sub) ->
 165         let sub = List.map parse_condition sub in
 166         (fun ri -> List.for_all (fun cond -> cond ri) sub)
 167     | Element ("and" as s, _, _) -> badconfig "Bad syntax for tag %s" s
 168
 169     | Element ("or", [], sub) ->
 170         let sub = List.map parse_condition sub in
 171         (fun ri -> List.exists (fun cond -> cond ri) sub)
 172     | Element ("or" as s, _, _) -> badconfig "Bad syntax for tag %s" s
 173
 174     | Element ("not", [], [sub]) ->
 175         let sub = parse_condition sub in
 176         (fun ri -> not (sub ri))
 177     | Element ("not" as s, _, _) -> badconfig "Bad syntax for tag %s" s
 178
 179     | _ ->
 180         badconfig "Bad syntax for condition"
 181
 182
 183 (*****************************************************************************)
 184 (* Parsing filters *)
 185
 186 let parse_config parse_fun = function
 187
 188   | Element ("if", [], sub) ->
 189       let (condition, sub) = match sub with
 190         | cond::q -> (parse_condition cond, q)
 191         | _ -> badconfig "Bad condition in <if>"
 192       in
 193       let (ithen, sub) = match sub with
 194           | Element("then", [], ithen)::q -> (parse_fun ithen, q)
 195           | _ -> badconfig "Bad <then> branch in <if>"
 196       in
 197       let (ielse, sub) = match sub with
 198           | Element ("else", [], ielse)::([] as q) -> (parse_fun ielse, q)
 199           | [] -> (parse_fun [], [])
 200           | _ -> badconfig "Bad <else> branch in <if>"
 201       in
 202       (function
 203         | Ocsigen_extensions.Req_found (ri, _)
 204         | Ocsigen_extensions.Req_not_found (_, ri) ->
 205             Lwt.return
 206               (if condition ri.request_info then begin
 207                  Ocsigen_messages.debug2 "--Access control: => going into <then> branch";
 208                  Ocsigen_extensions.Ext_sub_result ithen
 209                end
 210                else begin
 211                  Ocsigen_messages.debug2 "--Access control: => going into <else> branch, if any";
 212                  Ocsigen_extensions.Ext_sub_result ielse
 213                end))
 214   | Element ("if" as s, _, _) -> badconfig "Bad syntax for tag %s" s
 215
 216
 217   | Element ("notfound", [], []) ->
 218       (fun rs ->
 219          Ocsigen_messages.debug2 "--Access control: taking in charge 404";
 220          Lwt.return (Ocsigen_extensions.Ext_stop_all
 221                        (Ocsigen_http_frame.Cookies.empty, 404)))
 222   | Element ("notfound" as s, _, _) -> badconfig "Bad syntax for tag %s" s
 223
 224   | Element ("nextsite", [], []) ->
 225       (function
 226          | Ocsigen_extensions.Req_found (_, r) ->
 227              Lwt.return (Ocsigen_extensions.Ext_found_stop
 228                            (fun () -> Lwt.return r))
 229          | Ocsigen_extensions.Req_not_found (err, ri) ->
 230              Lwt.return (Ocsigen_extensions.Ext_stop_site
 231                            (Ocsigen_http_frame.Cookies.empty, 404)))
 232
 233   | Element ("nexthost", [], []) ->
 234       (function
 235          | Ocsigen_extensions.Req_found (_, r) ->
 236              Lwt.return (Ocsigen_extensions.Ext_found_stop
 237                            (fun () -> Lwt.return r))
 238          | Ocsigen_extensions.Req_not_found (err, ri) ->
 239              Lwt.return (Ocsigen_extensions.Ext_stop_host
 240                            (Ocsigen_http_frame.Cookies.empty, 404)))
 241   | Element ("nextsite" as s, _, _) -> badconfig "Bad syntax for tag %s" s
 242
 243   | Element ("stop", [], []) ->
 244       (function
 245          | Ocsigen_extensions.Req_found (_, r) ->
 246              Lwt.return (Ocsigen_extensions.Ext_found_stop
 247                            (fun () -> Lwt.return r))
 248          | Ocsigen_extensions.Req_not_found (err, ri) ->
 249              Lwt.return (Ocsigen_extensions.Ext_stop_all
 250                            (Ocsigen_http_frame.Cookies.empty, 404)))
 251   | Element ("stop" as s, _, _) -> badconfig "Bad syntax for tag %s" s
 252
 253   | Element ("forbidden", [], []) ->
 254       (fun rs ->
 255          Ocsigen_messages.debug2 "--Access control: taking in charge 403";
 256          Lwt.return (Ocsigen_extensions.Ext_stop_all
 257                        (Ocsigen_http_frame.Cookies.empty, 403)))
 258   | Element ("forbidden" as s, _, _) -> badconfig "Bad syntax for tag %s" s
 259
 260   | Element ("iffound", [], sub) ->
 261       let ext = parse_fun sub in
 262       (function
 263          | Ocsigen_extensions.Req_found (_, _) ->
 264              Lwt.return (Ext_sub_result ext)
 265          | Ocsigen_extensions.Req_not_found (err, ri) ->
 266              Lwt.return (Ocsigen_extensions.Ext_next err))
 267   | Element ("iffound" as s, _, _) -> badconfig "Bad syntax for tag %s" s
 268
 269   | Element ("ifnotfound", [], sub) ->
 270       let ext = parse_fun sub in
 271       (function
 272          | Ocsigen_extensions.Req_found (_, r) ->
 273              Lwt.return (Ocsigen_extensions.Ext_found
 274                            (fun () -> Lwt.return r))
 275          | Ocsigen_extensions.Req_not_found (err, ri) ->
 276              Lwt.return (Ext_sub_result ext))
 277   | Element ("ifnotfound", [("code", s)], sub) ->
 278       let ext = parse_fun sub in
 279       let r = Netstring_pcre.regexp ("^"^s^"$") in
 280       (function
 281          | Ocsigen_extensions.Req_found (_, r) ->
 282              Lwt.return (Ocsigen_extensions.Ext_found
 283                            (fun () -> Lwt.return r))
 284          | Ocsigen_extensions.Req_not_found (err, ri) ->
 285              if Netstring_pcre.string_match r (string_of_int err) 0 <> None then
 286                Lwt.return (Ext_sub_result ext)
 287              else
 288                Lwt.return (Ocsigen_extensions.Ext_next err))
 289   | Element ("ifnotfound" as s, _, _) -> badconfig "Bad syntax for tag %s" s
 290
 291   | Element (t, _, _) -> raise (Bad_config_tag_for_extension t)
 292   | _ -> badconfig "(accesscontrol extension) Bad data"
 293
 294
 295
 296
 297 (*****************************************************************************)
 298 (** Registration of the extension *)
 299 let () = register_extension
 300   ~name:"accesscontrol"
 301   ~fun_site:(fun _ _ _ -> parse_config)
 302   ~user_fun_site:(fun _ _ _ _ -> parse_config)
 303   ()