remove most of Ip_address: and depend on ocaml-ipaddr

Author: hhugo

Makefile.options

@@ -29,10 +29,11 @@ ifeq "$(PREEMPTIVE)" "YES"
 LWT_EXTRA_PACKAGE:=lwt.extra
 endif
 
-BASE_PACKAGE := lwt
+BASE_PACKAGE := lwt ipaddr
 
 SERVER_PACKAGE := lwt.ssl           \
 	          ${LWT_EXTRA_PACKAGE} \
+            ipaddr            \
 	          netstring         \
 	          netstring-pcre    \
                   findlib           \
@@ -51,4 +52,3 @@ INITPACKAGE := \"$(shell ${OCAMLFIND} query -p-format -recursive        \
                \"${PROJECTNAME}.baselib\";      \
                \"${PROJECTNAME}.http\";         \
                \"${PROJECTNAME}\";              \
-

src/baselib/Makefile

@@ -1,6 +1,6 @@
 include ../../Makefile.config
 
-LIBS     := -package lwt.unix,netstring,netstring-pcre,cryptokit,findlib,tyxml,lwt.syntax,${LWT_EXTRA_PACKAGE}
+LIBS     := -package lwt.unix,netstring,netstring-pcre,cryptokit,findlib,tyxml,lwt.syntax,${LWT_EXTRA_PACKAGE},ipaddr
 OCAMLC   := $(OCAMLFIND) ocamlc${BYTEDBG} ${THREAD}
 OCAMLOPT := $(OCAMLFIND) ocamlopt ${OPTDBG} ${THREAD}
 OCAMLDOC := $(OCAMLFIND) ocamldoc

src/baselib/ocsigen_lib.ml

@@ -23,158 +23,8 @@ module String = String_base
 (*****************************************************************************)
 
 module Ip_address = struct
-
-  type t =
-    | IPv4 of int32
-    | IPv6 of int64 * int64
-
-  exception Invalid_ipaddress of string
-
-  let parse s =
-    let s = String.lowercase s in
-    let n = String.length s in
-    let is6 = String.contains s ':' in
-    let failwith fmt = Printf.ksprintf (fun s -> raise (Invalid_ipaddress s)) fmt in
-
-    let rec parse_hex i accu =
-      match (if i < n then s.[i] else ':') with
-      | '0'..'9' as c -> parse_hex (i+1) (16*accu+(int_of_char c)-48)
-      | 'a'..'f' as c -> parse_hex (i+1) (16*accu+(int_of_char c)-87)
-      | _ -> (i, accu)
-    in
-    let rec parse_dec i accu =
-      match (if i < n then s.[i] else '.') with
-      | '0'..'9' as c -> parse_dec (i+1) (10*accu+(int_of_char c)-48)
-      | _ -> (i, accu)
-    in
-    let rec next_is_dec i =
-      if i < n then
-	match s.[i] with
-        | ':' -> false
-        | '.' -> true
-        | _ -> next_is_dec (i+1)
-      else false
-    in
-    let rec parse_component i accu nb =
-      if i < n then
-	if next_is_dec i then
-          let (i1, a) = parse_dec i 0 in
-          if i1 = i || (i1 < n && s.[i1] <> '.') then failwith "invalid dot notation in %s (1)" s;
-          let (i2, b) = parse_dec (i1+1) 0 in
-          if i2 = i1 then failwith "invalid dot notation in %s (2)" s;
-          let component =
-            if a < 0 || a > 255 || b < 0 || b > 255 then
-              failwith "invalid dot notation in %s (3)" s
-            else (a lsl 8) lor b
-          in
-          if i2 < n-1 && (s.[i2] = ':' || s.[i2] = '.') then
-            parse_component (i2+1) (component::accu) (nb+1)
-          else
-            (i2, component::accu, nb+1)
-	else if s.[i] = ':' then
-          parse_component (i+1) ((-1)::accu) nb
-	else
-          let (i1, a) = parse_hex i 0 in
-          if a < 0 || a > 0xffff then failwith "invalid colon notation in %s" s;
-          if i1 = i then
-            (i, accu, nb)
-          else if i1 < n-1 && s.[i1] = ':' then
-            parse_component (i1+1) (a::accu) (nb+1)
-          else
-            (i1, a::accu, nb+1)
-      else
-	(i, accu, nb)
-    in
-
-    let (i, addr_list, size_list) =
-      if 1 < n && s.[0] = ':' && s.[1] = ':' then
-	parse_component 2 [-1] 0
-      else
-	parse_component 0 [] 0
-    in
-
-    if size_list > 8 then failwith "too many components in %s" s;
-
-    let maybe_mask =
-      if i < n && s.[i] = '/' then
-	let (i1, m) = parse_dec (i+1) 0 in
-	if i1 = i+1 || i1 < n || m < 0 || m > (if is6 then 128 else 32) then
-          failwith "invalid /n suffix in %s" s
-	else
-          Some m
-      else if i < n then
-	failwith "invalid suffix in %s (from index %i)" s i
-      else
-	None
-    in
-
-    if is6 then
-      let (++) a b = Int64.logor (Int64.shift_left a 16) (Int64.of_int b) in
-      let normalized =
-	let rec aux_add n accu =
-          if n = 0 then accu else aux_add (n-1) (0::accu)
-	in
-	let rec aux_rev accu = function
-          | [] -> accu
-          | (-1)::q -> aux_rev (aux_add (8-size_list) accu) q
-          | a::q -> aux_rev (a::accu) q
-	in
-	aux_rev [] addr_list
-      in
-      let maybe_mask = match maybe_mask with
-      | Some n when n > 64 ->
-          Some (IPv6 (Int64.minus_one, Int64.shift_left Int64.minus_one (128-n)))
-      | Some n ->
-          Some (IPv6 (Int64.shift_left Int64.minus_one (64-n), Int64.zero))
-      | None -> None
-      in
-      match normalized with
-      | [a; b; c; d; e; f; g; h] ->
-          IPv6 (Int64.zero ++ a ++ b ++ c ++ d,
-                Int64.zero ++ e ++ f ++ g ++ h), maybe_mask
-      | _ -> failwith "invalid IPv6 address: %s (%d components)" s (List.length normalized)
-    else
-      let (++) a b = Int32.logor (Int32.shift_left a 16) (Int32.of_int b) in
-      let maybe_mask = match maybe_mask with
-      | Some n ->
-          Some (IPv4 (Int32.shift_left Int32.minus_one (32-n)))
-      | None -> None
-      in
-      match addr_list with
-      | [b; a] ->
-          IPv4 (Int32.zero ++ a ++ b), maybe_mask
-      | _ -> failwith "invalid IPv4 address: %s" s
-
-
-  let match_ip (base, mask) ip =
-    match ip,  base, mask with
-    | IPv4 a, IPv4 b, Some (IPv4 m) -> Int32.logand a m = Int32.logand b m
-    | IPv4 a, IPv4 b, None -> a = b
-    | IPv6 (a1,a2), IPv6 (b1,b2), Some (IPv6 (m1,m2)) ->
-        Int64.logand a1 m1 = Int64.logand b1 m1 &&
-        Int64.logand a2 m2 = Int64.logand b2 m2
-    | IPv6 (a1,a2), IPv6 (b1,b2), None -> a1 = b1 && a2 = b2
-    | IPv6 (a1,a2), IPv4 b, c
-      when a1 = 0L && Int64.logand a2 0xffffffff00000000L = 0xffff00000000L ->
-        (* might be insecure, cf
-           http://tools.ietf.org/internet-drafts/draft-itojun-v6ops-v4mapped-harmful-02.txt *)
-        let a = Int64.to_int32 a2 in
-        begin match c with
-        | Some (IPv4 m) -> Int32.logand a m = Int32.logand b m
-        | Some (IPv6 _) -> invalid_arg "match_ip"
-        | None -> a = b
-        end
-    | _ -> false
-
-  let network_of_ip ip mask4 (mask61, mask62) = match ip with
-  | IPv4 a -> IPv4 (Int32.logand a mask4)
-  | IPv6 (a, b) -> IPv6 (Int64.logand a mask61, Int64.logand b mask62)
-
   exception No_such_host
 
-  let inet6_addr_loopback =
-    fst (parse (Unix.string_of_inet_addr Unix.inet6_addr_loopback))
-
   let get_inet_addr ?(v6=false) host =
     let rec aux = function
       | [] -> Lwt.fail No_such_host
@@ -186,22 +36,6 @@ module Ip_address = struct
       (Lwt_unix.getaddrinfo host "" options)
       aux
 
-(*
-  let getnameinfo ia p =
-    try
-      Lwt_unix.getnameinfo (Unix.ADDR_INET (ia, p)) [Unix.NI_NAMEREQD] >>= fun r ->
-	Lwt.return r.Unix.ni_hostname
-    with
-    | Not_found ->
-	let hs = Unix.string_of_inet_addr ia in
-	Lwt.return
-          (if String.length hs > 7 && String.sub hs 0 7 = "::ffff:"
-          then String.sub hs 7 (String.length hs - 7)
-          else if String.contains hs ':'
-          then "["^hs^"]"
-          else hs)
-
- *)
 end
 
 (*****************************************************************************)

src/baselib/ocsigen_lib.mli

@@ -36,25 +36,8 @@ val make_cryptographic_safe_string : unit -> string
 module String : module type of String_base
 
 module Ip_address : sig
-
-  type t =
-    | IPv4 of int32
-    | IPv6 of int64 * int64
-
-  (* exception Invalid_ipaddress of string *)
-
-  val parse : string -> t * (t option)
-  val match_ip : t * (t option) -> t -> bool
-  val network_of_ip : t -> int32 -> int64 * int64 -> t
-
   exception No_such_host
-
-  val inet6_addr_loopback : t
-
   val get_inet_addr : ?v6:bool -> string -> Unix.inet_addr Lwt.t
-
-  (* val getnameinfo : Unix.inet_addr -> int -> string Lwt.t *)
-
 end
 
 module Filename : sig

src/extensions/Makefile

@@ -1,6 +1,7 @@
 include ../../Makefile.config
 
 PACKAGE  := lwt.unix     \
+			ipaddr       \
 	    lwt.ssl      \
 	    lwt.react    \
             netstring    \

src/extensions/accesscontrol.ml

@@ -43,16 +43,18 @@ open Ocsigen_http_frame
 let rec parse_condition = function
 
     | Element ("ip", ["value", s], []) ->
-        let ip_with_mask =
+        let prefix =
           try
-            Ip_address.parse s
-          with Failure _ ->
-            badconfig "Bad ip/netmask [%s] in <ip> condition" s
+            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 _ ->
+              badconfig "Bad ip/netmask [%s] in <ip> condition" s
         in
         (fun ri ->
-           let r = 
-             Ip_address.match_ip ip_with_mask 
-               (Lazy.force ri.ri_remote_ip_parsed) 
+           let r = Ipaddr.mem prefix (Lazy.force ri.ri_remote_ip_parsed)
            in
            if r then
              Ocsigen_messages.debug2 (sprintf "--Access control (ip): %s matches %s" ri.ri_remote_ip s)
@@ -230,10 +232,10 @@ let parse_config parse_fun = function
   | Element ("nextsite", [], []) ->
       (function
          | Ocsigen_extensions.Req_found (_, r) ->
-             Lwt.return (Ocsigen_extensions.Ext_found_stop 
+             Lwt.return (Ocsigen_extensions.Ext_found_stop
                            (fun () -> Lwt.return r))
          | Ocsigen_extensions.Req_not_found (err, ri) ->
-             Lwt.return (Ocsigen_extensions.Ext_stop_site 
+             Lwt.return (Ocsigen_extensions.Ext_stop_site
                            (Ocsigen_cookies.Cookies.empty, 404)))
 
   | Element ("nexthost", [], []) ->

src/files/META.in

@@ -100,7 +100,7 @@ package "ext" (
 
   package "accesscontrol" (
     exists_if = "accesscontrol.cmo,accesscontrol.cmx"
-    requires = "ocsigenserver"
+    requires = "ocsigenserver,ipaddr"
     version = "[distributed with Ocsigen server]"
     description = "Filtering HTTP requests"
     archive(byte) = "accesscontrol.cmo"

src/server/ocsigen_extensions.ml

@@ -216,7 +216,7 @@ type request_info =
      ri_files: (config_info -> (string * file_info) list Lwt.t) option; (** Files sent in the request (multipart data). None if other content type or no content. *)
      ri_remote_inet_addr: Unix.inet_addr; (** IP of the client *)
      ri_remote_ip: string;            (** IP of the client *)
-     ri_remote_ip_parsed: Ip_address.t Lazy.t;    (** IP of the client, parsed *)
+     ri_remote_ip_parsed: Ipaddr.t Lazy.t;    (** IP of the client, parsed *)
      ri_remote_port: int;      (** Port used by the client *)
      ri_forward_ip: string list; (** IPs of gateways the request went throught *)
      ri_server_port: int;      (** Port of the request (server) *)

src/server/ocsigen_extensions.mli

@@ -164,7 +164,7 @@ type request_info =
      ri_files: (config_info -> (string * file_info) list Lwt.t) option; (** Files sent in the request (multipart data). None if other content type or no content. *)
      ri_remote_inet_addr: Unix.inet_addr; (** IP of the client *)
      ri_remote_ip: string;            (** IP of the client *)
-     ri_remote_ip_parsed: Ip_address.t Lazy.t;    (** IP of the client, parsed *)
+     ri_remote_ip_parsed: Ipaddr.t Lazy.t;    (** IP of the client, parsed *)
      ri_remote_port: int;      (** Port used by the client *)
      ri_forward_ip: string list; (** IPs of gateways the request went throught *)
      ri_server_port: int;      (** Port of the request (server) *)

src/server/ocsigen_server.ml

@@ -382,7 +382,7 @@ let get_request_infos
           ri_files = files;
           ri_remote_inet_addr = client_inet_addr;
           ri_remote_ip = ipstring;
-          ri_remote_ip_parsed = lazy (fst (Ip_address.parse ipstring));
+          ri_remote_ip_parsed = lazy (Ipaddr.of_string_exn ipstring);
           ri_remote_port = port_of_sockaddr sockaddr;
 	  ri_forward_ip = [];
           ri_server_port = port;