Merge branch 'ipaddr' of https://github.com/hhugo/ocsigenserver into hhugo-ipaddr

Conflicts:
	README

Author: Vincent Balat

Makefile.dist

@@ -16,7 +16,7 @@
 ##
 
 #VERSION?=$(shell grep Version: _oasis | cut -d ' ' -f 2)
-VERSION=`cat VERSION`
+VERSION=$(shell cat VERSION)
 REPO?=https://github.com/ocsigen/ocsigenserver
 
 all: dist sign

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}\";              \
-

README

@@ -15,15 +15,17 @@ Libraries:
  * findlib
  * react             (tested with 0.9.3)
  * ocamlssl          (tested with 0.4.6)
- * lwt 	             (need version >= 2.4.2, with react and ssl support)
+ * lwt               (need version >= 2.4.2, with react and ssl support)
  * ocamlnet          (tested with 3.6, with netstring, netstring-pcre and netsys)
  * pcre-ocaml        (tested with 6.2.5)
  * cryptokit         (tested with 1.6)
  * ocaml-text        (tested with 0.6)
  * tyxml             (need version 2.2)
+ * ipaddr            (need version >= 2.1)
  * ocamlsqlite3      (tested with 2.0.2) OR
  * dbm               (tested with 1.0)
 
+
 Optional libraries:
 
  * camlzip           (tested with 1.04)

doc/indexdoc

@@ -11,7 +11,7 @@ Ocsipersist
 Ocsigen_config
 }
 
-{2 Extending Ocsigen}
+{2 Extending Ocsigen Server}
 {!modules:
 Ocsigen_extensions
 Ocsigen_local_files

opam/opam

@@ -20,6 +20,7 @@ depends: [
   "cryptokit"
   "tyxml" {>= "9999"}
   ("dbm" | "sqlite3-ocaml")
+  "ipaddr" {>= "2.1"}
 ]
 depopts: [
   "camlzip" {>= "1.04"}

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_config.mli

@@ -16,6 +16,8 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  *)
 
+(** Configuring Ocsigen server *)
+
 open Ocsigen_lib
 
 exception Config_file_error of string

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    \