(* Ocsigen
 * http://www.ocsigen.org
 * Module accesscontrol.ml
 * Copyright (C) 2007 Vincent Balat, Stéphane Glondu
 *
 * 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.
 *)

(* Filtering requests via the configuration file *)

open Ocsigen_lib
open Xml

let section = Lwt_log.Section.make "ocsigen:ext:access-control"

let rec parse_condition = function
  | Element ("ip", [("value", s)], []) ->
      let prefix =
        try Ipaddr.Prefix.of_string_exn s
        with Ipaddr.Parse_error _ -> (
          try
            let ip = Ipaddr.of_string_exn s in
            Ipaddr.Prefix.of_addr ip
          with _ ->
            Ocsigen_extensions.badconfig "Bad ip/netmask [%s] in <ip> condition"
              s)
      in
      fun ri ->
        let r =
          Ipaddr.Prefix.mem (Ocsigen_request.remote_ip_parsed ri) prefix
        in
        if r
        then
          Lwt_log.ign_info_f ~section "IP: %a matches %s"
            (fun () -> Ocsigen_request.remote_ip)
            ri s
        else
          Lwt_log.ign_info_f ~section "IP: %a does not match %s"
            (fun () -> Ocsigen_request.remote_ip)
            ri s;
        r
  | Element (("ip" as s), _, _) ->
      Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | Element ("port", [("value", s)], []) ->
      let port =
        try int_of_string s
        with Failure _ ->
          Ocsigen_extensions.badconfig "Bad port [%s] in <port> condition" s
      in
      fun ri ->
        let r = Ocsigen_request.port ri = port in
        if r
        then Lwt_log.ign_info_f ~section "PORT: %d accepted" port
        else
          Lwt_log.ign_info_f ~section "PORT: %a not accepted (%d expected)"
            (fun () ri -> string_of_int (Ocsigen_request.port ri))
            ri port;
        r
  | Element (("port" as s), _, _) ->
      Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | Element ("ssl", [], []) ->
      fun ri ->
        let r = Ocsigen_request.ssl ri in
        if r
        then Lwt_log.ign_info ~section "SSL: accepted"
        else Lwt_log.ign_info ~section "SSL: not accepted";
        r
  | Element (("ssl" as s), _, _) ->
      Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | Element ("header", [("name", name); ("regexp", reg)], []) ->
      let regexp =
        try Netstring_pcre.regexp ("^" ^ reg ^ "$")
        with Failure _ ->
          Ocsigen_extensions.badconfig
            "Bad regular expression [%s] in <header> condition" reg
      in
      fun ri ->
        let r =
          List.exists
            (fun a ->
              let r = Netstring_pcre.string_match regexp a 0 <> None in
              if r
              then Lwt_log.ign_info_f "HEADER: header %s matches %S" name reg;
              r)
            (Ocsigen_request.header_multi ri
               (Ocsigen_header.Name.of_string name))
        in
        if not r
        then Lwt_log.ign_info_f "HEADER: header %s does not match %S" name reg;
        r
  | Element (("header" as s), _, _) ->
      Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | Element ("method", [("value", s)], []) ->
      fun ri ->
        let m = Cohttp.Code.method_of_string s
        and m' = Ocsigen_request.meth ri in
        let s' = Cohttp.Code.string_of_method m' in
        let r = m = m' in
        if r
        then Lwt_log.ign_info_f ~section "METHOD: %s matches %s" s' s
        else Lwt_log.ign_info_f ~section "METHOD: %s does not match %s" s' s;
        r
  | Element (("method" as s), _, _) ->
      Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | Element ("protocol", [("value", s)], []) ->
      fun ri ->
        let v = Cohttp.Code.version_of_string s
        and v' = Ocsigen_request.version ri in
        let s' = Cohttp.Code.string_of_version v' in
        let r = v = v' in
        if r
        then Lwt_log.ign_info_f ~section "PROTOCOL: %s matches %s" s' s
        else Lwt_log.ign_info_f ~section "PROTOCOL: %s does not match %s" s' s;
        r
  | Element (("protocol" as s), _, _) ->
      Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | Element ("path", [("regexp", s)], []) ->
      let regexp =
        try Netstring_pcre.regexp ("^" ^ s ^ "$")
        with Failure _ ->
          Ocsigen_extensions.badconfig
            "Bad regular expression [%s] in <path> condition" s
      in
      fun ri ->
        let sps = Ocsigen_request.sub_path_string ri in
        let r = Netstring_pcre.string_match regexp sps 0 <> None in
        if r
        then Lwt_log.ign_info_f ~section "PATH: \"%s\" matches %S" sps s
        else Lwt_log.ign_info_f ~section "PATH: \"%s\" does not match %S" sps s;
        r
  | Element (("path" as s), _, _) ->
      Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | Element ("and", [], sub) ->
      let sub = List.map parse_condition sub in
      fun ri -> List.for_all (fun cond -> cond ri) sub
  | Element (("and" as s), _, _) ->
      Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | Element ("or", [], sub) ->
      let sub = List.map parse_condition sub in
      fun ri -> List.exists (fun cond -> cond ri) sub
  | Element (("or" as s), _, _) ->
      Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | Element ("not", [], [sub]) ->
      let sub = parse_condition sub in
      fun ri -> not (sub ri)
  | Element (("not" as s), _, _) ->
      Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | _ -> Ocsigen_extensions.badconfig "Bad syntax for condition"

(*****************************************************************************)
(* Parsing filters *)

let comma_space_regexp = Netstring_pcre.regexp "\ *,\ *"

let parse_config parse_fun = function
  | Element ("if", [], sub) -> (
      let condition, sub =
        match sub with
        | cond :: q -> parse_condition cond, q
        | _ -> Ocsigen_extensions.badconfig "Bad condition in <if>"
      in
      let ithen, sub =
        match sub with
        | Element ("then", [], ithen) :: q -> parse_fun ithen, q
        | _ -> Ocsigen_extensions.badconfig "Bad <then> branch in <if>"
      in
      let ielse, _sub =
        match sub with
        | Element ("else", [], ielse) :: ([] as q) -> parse_fun ielse, q
        | [] -> parse_fun [], []
        | _ -> Ocsigen_extensions.badconfig "Bad <else> branch in <if>"
      in
      function
      | Ocsigen_extensions.Req_found (ri, _)
      | Ocsigen_extensions.Req_not_found (_, ri) ->
          Lwt.return
            (if condition ri.Ocsigen_extensions.request_info
            then (
              Lwt_log.ign_info ~section "COND: going into <then> branch";
              Ocsigen_extensions.Ext_sub_result ithen)
            else (
              Lwt_log.ign_info ~section "COND: going into <else> branch, if any";
              Ocsigen_extensions.Ext_sub_result ielse)))
  | Element (("if" as s), _, _) ->
      Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | Element ("notfound", [], []) ->
      fun _rs ->
        Lwt_log.ign_info ~section "NOT_FOUND: taking in charge 404";
        Lwt.return
          (Ocsigen_extensions.Ext_stop_all (Ocsigen_cookie_map.empty, `Not_found))
  | Element (("notfound" as s), _, _) ->
      Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | Element ("nextsite", [], []) -> (
      function
      | Ocsigen_extensions.Req_found (_, r) ->
          Lwt.return
            (Ocsigen_extensions.Ext_found_stop (fun () -> Lwt.return r))
      | Ocsigen_extensions.Req_not_found _ ->
          Lwt.return
            (Ocsigen_extensions.Ext_stop_site
               (Ocsigen_cookie_map.empty, `Not_found)))
  | Element ("nexthost", [], []) -> (
      function
      | Ocsigen_extensions.Req_found (_, r) ->
          Lwt.return
            (Ocsigen_extensions.Ext_found_stop (fun () -> Lwt.return r))
      | Ocsigen_extensions.Req_not_found _ ->
          Lwt.return
            (Ocsigen_extensions.Ext_stop_host
               (Ocsigen_cookie_map.empty, `Not_found)))
  | Element (("nextsite" as s), _, _) ->
      Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | Element ("stop", [], []) -> (
      function
      | Ocsigen_extensions.Req_found (_, r) ->
          Lwt.return
            (Ocsigen_extensions.Ext_found_stop (fun () -> Lwt.return r))
      | Ocsigen_extensions.Req_not_found _ ->
          Lwt.return
            (Ocsigen_extensions.Ext_stop_all
               (Ocsigen_cookie_map.empty, `Not_found)))
  | Element (("stop" as s), _, _) ->
      Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | Xml.Element ("forbidden", [], []) ->
      fun _rs ->
        Lwt_log.ign_info ~section "FORBIDDEN: taking in charge 403";
        Lwt.return
          (Ocsigen_extensions.Ext_stop_all (Ocsigen_cookie_map.empty, `Forbidden))
  | Element (("forbidden" as s), _, _) ->
      Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | Element ("iffound", [], sub) -> (
      let ext = parse_fun sub in
      function
      | Ocsigen_extensions.Req_found (_, _) ->
          Lwt.return (Ocsigen_extensions.Ext_sub_result ext)
      | Ocsigen_extensions.Req_not_found (err, _ri) ->
          Lwt.return (Ocsigen_extensions.Ext_next err))
  | Element (("iffound" as s), _, _) ->
      Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | Element ("ifnotfound", [], sub) -> (
      let ext = parse_fun sub in
      function
      | Ocsigen_extensions.Req_found (_, r) ->
          Lwt.return (Ocsigen_extensions.Ext_found (fun () -> Lwt.return r))
      | Ocsigen_extensions.Req_not_found _ ->
          Lwt.return (Ocsigen_extensions.Ext_sub_result ext))
  | Element ("ifnotfound", [("code", s)], sub) -> (
      let ext = parse_fun sub in
      let r = Netstring_pcre.regexp ("^" ^ s ^ "$") in
      function
      | Ocsigen_extensions.Req_found (_, r) ->
          Lwt.return (Ocsigen_extensions.Ext_found (fun () -> Lwt.return r))
      | Ocsigen_extensions.Req_not_found (err, _ri) ->
          if let err =
               string_of_int Cohttp.Code.(code_of_status (err :> status_code))
             in
             Netstring_pcre.string_match r err 0 <> None
          then Lwt.return (Ocsigen_extensions.Ext_sub_result ext)
          else Lwt.return (Ocsigen_extensions.Ext_next err))
  | Element (("ifnotfound" as s), _, _) ->
      Ocsigen_extensions.badconfig "Bad syntax for tag %s" s
  | Element ("allow-forward-for", param, _) -> (
      let apply ({Ocsigen_extensions.request_info; _} as request) code =
        Lwt_log.ign_info ~section "Allowed proxy";
        let request =
          let header =
            Ocsigen_request.header request_info
              Ocsigen_header.Name.x_forwarded_for
          in
          match header with
          | Some header -> (
            match
              Ocsigen_lib.Netstring_pcre.split comma_space_regexp header
            with
            | original_ip :: proxies ->
                let last_proxy = List.last proxies in
                let proxy_ip = Ipaddr.of_string_exn last_proxy in
                let equal_ip =
                  proxy_ip = Ocsigen_request.remote_ip_parsed request_info
                in
                let need_equal_ip =
                  match param with
                  | [] -> false
                  | [("check-equal-ip", b)] -> (
                    try bool_of_string b
                    with Invalid_argument _ ->
                      Ocsigen_extensions.badconfig
                        "Bad syntax for argument of tag allow-forward-for")
                  | _ ->
                      Ocsigen_extensions.badconfig
                        "Bad syntax for argument of tag allow-forward-for"
                in
                if equal_ip || not need_equal_ip
                then
                  { request with
                    Ocsigen_extensions.request_info =
                      Ocsigen_request.update ~forward_ip:proxies
                        ~remote_ip:original_ip request_info }
                else (
                  (* the announced ip of the proxy is not its real ip *)
                  Lwt_log.ign_warning_f ~section
                    "X-Forwarded-For: host ip (%s) does not match the header (%s)"
                    (Ocsigen_request.remote_ip request_info)
                    header;
                  request)
            | _ ->
                Lwt_log.ign_info_f ~section
                  "Malformed X-Forwarded-For field: %s" header;
                request)
          | None -> request
        in
        Lwt.return
          (Ocsigen_extensions.Ext_continue_with
             (request, Ocsigen_cookie_map.empty, code))
      in
      function
      | Ocsigen_extensions.Req_found (request, resp) ->
          apply request (Ocsigen_response.status resp)
      | Ocsigen_extensions.Req_not_found (code, request) -> apply request code)
  | Element ("allow-forward-proto", _, _) -> (
      let apply ({Ocsigen_extensions.request_info; _} as request) code =
        Lwt_log.ign_info ~section "Allowed proxy for ssl";
        let request_info =
          let header =
            Ocsigen_request.header request_info
              Ocsigen_header.Name.x_forwarded_proto
          in
          match header with
          | Some header -> (
            match String.lowercase_ascii header with
            | "http" -> Ocsigen_request.update ~ssl:false request_info
            | "https" -> Ocsigen_request.update ~ssl:true request_info
            | _ ->
                Lwt_log.ign_info_f ~section
                  "Malformed X-Forwarded-Proto field: %s" header;
                request_info)
          | None -> request_info
        in
        Lwt.return
          (Ocsigen_extensions.Ext_continue_with
             ( {request with Ocsigen_extensions.request_info}
             , Ocsigen_cookie_map.empty
             , code ))
      in
      function
      | Ocsigen_extensions.Req_found (request, resp) ->
          apply request (Ocsigen_response.status resp)
      | Ocsigen_extensions.Req_not_found (code, request) -> apply request code)
  | Element (t, _, _) ->
      raise (Ocsigen_extensions.Bad_config_tag_for_extension t)
  | _ -> Ocsigen_extensions.badconfig "(accesscontrol extension) Bad data"

(* Registration of the extension *)
let () =
  Ocsigen_extensions.register ~name:"accesscontrol"
    ~fun_site:(fun _ _ _ _ _ -> parse_config)
    ()
