Merge http://github.com/mor1/ocaml-uri

Conflicts:
	lib_test/test_runner.ml

.gitignore

@@ -7,3 +7,4 @@ setup.bin
 *.native
 *.byte
 *.docdir
+*.annot

Makefile

@@ -2,13 +2,16 @@
 all: build test doc
 
 NAME=uri
+OFLAGS=-annot
 J=4
 
 export OCAMLRUNPARAM=b
 
 setup.bin: setup.ml
-	ocamlopt.opt -o $@ $< || ocamlopt -o $@ $< || ocamlc -o $@ $<
-	rm -f setup.cmx setup.cmi setup.o setup.cmo
+	ocamlopt.opt $(OFLAGS) -o $@ $< 	\
+	  || ocamlopt $(OFLAGS) -o $@ $< 	\
+	  || ocamlc $(OFLAGS) -o $@ $<
+	$(RM) setup.cmx setup.cmi setup.o setup.cmo
 
 setup.data: setup.bin
 	./setup.bin -configure
@@ -31,4 +34,4 @@ reinstall: setup.bin
 
 clean:
 	ocamlbuild -clean
-	rm -f setup.data setup.log setup.bin
+	$(RM) setup.data setup.log setup.bin

README.md

@@ -5,11 +5,12 @@ Build requirements:
 * [oUnit](http://ounit.forge.ocamlcore.org/) unit testing library.
 
 Much assistance for the regular expressions from:
-http://jmrware.com/articles/2009/uri_regexp/URI_regex.html
+<http://jmrware.com/articles/2009/uri_regexp/URI_regex.html>
 
 TODO (at least):
 
-* form encoding (' ' to '+'). Python has a `quote_plus` for this as it is different behaviour from normal URL percent encoding.
-* query argument decoding
-* path normalisation (`a/b/..` to `a/b`)
-* relative url resolution
++ form encoding (' ' to '+'). Python has a `quote_plus` for this as it is
+  different behaviour from normal URL percent encoding.
++ query argument decoding
++ path normalisation (`a/b/..` to `a/b`)
++ relative url resolution

lib/iP.ml

@@ -0,0 +1,53 @@
+(*
+ * Copyright (c) 2012 Richard Mortier <mort@cantab.net>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *
+ *)
+
+open Operators
+open Re
+
+type ipv4 = int32
+type ipv6 = int32 * int32 * int32 * int32
+
+let int32_of_byte b = b |> int_of_char |> Int32.of_int
+
+let string_of_ipv4 i =   
+  sp "%ld.%ld.%ld.%ld" 
+    ((i &&& 0x0_ff000000_l) >>> 24) ((i &&& 0x0_00ff0000_l) >>> 16)
+    ((i &&& 0x0_0000ff00_l) >>>  8) ((i &&& 0x0_000000ff_l)       )
+
+let ipv4_of_bytes bs = 
+  ((bs.[0] |> int32_of_byte <<< 24) ||| (bs.[1] |> int32_of_byte <<< 16) 
+    ||| (bs.[2] |> int32_of_byte <<< 8) ||| (bs.[3] |> int32_of_byte))
+
+let string_of_ipv6 i = 
+  (* should make this rfc 5952 compliant *)
+
+  let i1, i2, i3, i4 = i in
+  let s = sp "%lx:%lx:%lx:%lx:%lx:%lx:%lx:%lx"
+    ((i1 &&& 0x0_ffff0000_l) >>> 16) ((i1 &&& 0x0_0000ffff_l))
+    ((i2 &&& 0x0_ffff0000_l) >>> 16) ((i2 &&& 0x0_0000ffff_l))
+    ((i3 &&& 0x0_ffff0000_l) >>> 16) ((i3 &&& 0x0_0000ffff_l))
+    ((i4 &&& 0x0_ffff0000_l) >>> 16) ((i4 &&& 0x0_0000ffff_l))
+  in
+  s
+
+let ipv6_of_bytes bs = 
+  (ipv4_of_bytes (String.sub bs 0 4), ipv4_of_bytes (String.sub bs 4 4),
+   ipv4_of_bytes (String.sub bs 8 4), ipv4_of_bytes (String.sub bs 12 4))
+
+let _ = 
+  Printf.printf "++ %s" 
+    (string_of_ipv6 (0xde000000_l, 0xdeadbeef_l, 0x00000000_l, 0xdeadbeef_l))

lib/iP.mli

@@ -0,0 +1,25 @@
+(*
+ * Copyright (c) 2012 Richard Mortier <mort@cantab.net>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *
+ *)
+
+type ipv4 = int32
+type ipv6 = int32 * int32 * int32 * int32
+
+val int32_of_byte : char -> int32
+val string_of_ipv4 : int32 -> string
+val ipv4_of_bytes : string -> int32
+val string_of_ipv6 : int32 * int32 * int32 * int32 -> string
+val ipv6_of_bytes : string -> int32 * int32 * int32 * int32

lib/operators.ml

@@ -0,0 +1,25 @@
+(*
+ * Copyright (c) 2012 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2011 Richard Mortier <mort@cantab.net>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+let (|>) x f = f x (* pipe *)
+let (&&&) x y = Int32.logand x y
+let (|||) x y = Int32.logor x y
+let (<<<) x y = Int32.shift_left x y
+let (>>>) x y = Int32.shift_right_logical x y
+
+let sp = Printf.sprintf
+

lib/operators.mli

@@ -0,0 +1,23 @@
+(*
+ * Copyright (c) 2012 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2012 Richard Mortier <mort@cantab.net>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+
+val ( |> ) : 'a -> ('a -> 'b) -> 'b
+val ( &&& ) : int32 -> int32 -> int32
+val ( ||| ) : int32 -> int32 -> int32
+val ( <<< ) : int32 -> int -> int32
+val ( >>> ) : int32 -> int -> int32
+val sp : ('a, unit, string) format -> 'a

lib/uri_re.ml

@@ -38,9 +38,34 @@ module Raw = struct
 
   let dec_octet = Re_posix.re "25[0-5]|2[0-4][0-9]|[01]?[0-9][0-9]?"
   let ipv4_address = (repn (dec_octet + c_dot) 3 (Some 3)) + dec_octet
+
+  (* following RFC2234, RFC3986 and 
+     http://people.spodhuis.org/phil.pennock/software/emit_ipv6_regexp-0.304 
+  *)
+  let ipv6_address = 
+    let (=|) n a = repn a n (Some n) in
+    let (<|) n a = repn a 0 (Some n) in
+    let h16 = repn hexdig 1 (Some 4) in
+    let h16c = h16 + c_colon in
+    let cc = c_colon + c_colon in
+    let ls32 = (h16c + h16) / ipv4_address in
+    ( char '[' 
+      + (((6=|h16c) + ls32)
+         / (                         cc + (5=|h16c) + ls32)
+         / ((1<|             h16)  + cc + (4=|h16c) + ls32)
+         / ((1<|((1<|h16c) + h16)) + cc + (3=|h16c) + ls32)
+         / ((1<|((2<|h16c) + h16)) + cc + (2=|h16c) + ls32)
+         / ((1<|((3<|h16c) + h16)) + cc +     h16c  + ls32)
+         / ((1<|((4<|h16c) + h16)) + cc             + ls32)
+         / ((1<|((5<|h16c) + h16)) + cc             +  h16)
+         / ((1<|((6<|h16c) + h16)) + cc                   )
+      ) 
+      + char ']'
+    )
+
   let reg_name = rep ( unreserved / pct_encoded / sub_delims )
 
-  let host = ipv4_address / reg_name (* | ipv4_literal TODO *)
+  let host = ipv6_address / ipv4_address / reg_name (* | ipv4_literal TODO *)
   let userinfo = rep (unreserved / pct_encoded / sub_delims / c_colon)
   let port = Re_posix.re "[0-9]*"
   let authority = (opt ((group userinfo) + c_at)) + (group host) + (opt (c_colon + (group port)))

lib_test/test_runner.ml

@@ -53,6 +53,8 @@ let uri_encodes = [
   "http://foo%21.com", (Uri.make ~scheme:"http" ~host:"foo!.com" ());
   "/wh/at/ev/er", (Uri.make ~path:"/wh/at/ev/er" ());
   "/wh/at%21/ev%20/er", (Uri.make ~path:"/wh/at!/ev /er" ());
+  "http://%5Bdead%3Abeef%3A%3Adead%3A0%3Abeaf%5D",
+    (Uri.make ~scheme:"http" ~host:"[dead:beef::dead:0:beaf]" ())
 ]
 
 let map_pcts_tests size name test args =