Merge branch 'master' of http://github.com/avsm/mirage

Conflicts:
	lib/os/Makefile

INSTALL.md

@@ -67,7 +67,7 @@ in Xen with a config file like:
     $ cat > sleep.cfg
     name="sleep"
     memory=1024
-    kernel="_build/sleep.bin"
+    kernel="_build/sleep.xen"
     <control-d>
     $ sudo xm create -c sleep.cfg
 

Makefile

@@ -11,6 +11,9 @@ export DESTDIR
 PREFIX ?= $(HOME)/mir-inst
 export PREFIX
 
+JOBS=-j 6
+export JOBS
+
 all: tools
 	cd lib && $(MAKE)
 

assemble.sh

@@ -28,7 +28,7 @@ function assemble_xen {
     done
     cp ${ROOT}/lib/os/runtime_xen/kernel/mirage-x86_64.lds ${OBJ}/lib/
     cp ${ROOT}/lib/net/direct/_build/xen/net.{cmi,cmxa,a} ${OBJ}/lib/
-    cp ${ROOT}/lib/net/direct/_build/xen/net.{cmi,cmxa,a} ${OBJ}/lib/
+    cp ${ROOT}/lib/block/direct/_build/xen/block.{cmi,cmxa,a} ${OBJ}/lib/
     for i in dns http; do 
       cp ${ROOT}/lib/$i/_build/xen-direct/$i.{cmi,cmxa,a} ${OBJ}/lib/;
     done

lib/Makefile

@@ -4,6 +4,7 @@ all:
 	cd std && $(MAKE)
 	cd os && $(MAKE)
 	cd net && $(MAKE)
+	cd block && $(MAKE)
 	cd dns && $(MAKE)
 	cd dyntype && $(MAKE)
 	cd http && $(MAKE)
@@ -14,6 +15,7 @@ clean:
 	cd std && $(MAKE) clean
 	cd os && $(MAKE) clean
 	cd net && $(MAKE) clean
+	cd block && $(MAKE) clean
 	cd dns && $(MAKE) clean
 	cd dyntype && $(MAKE) clean
 	cd http && $(MAKE) clean

lib/block/Makefile

@@ -0,0 +1,6 @@
+.PHONY: all clean
+all:
+	cd direct && $(MAKE)
+
+clean:
+	cd direct && $(MAKE) clean

lib/block/direct/Makefile

@@ -0,0 +1,28 @@
+.PHONY: clean all install
+
+PREFIX ?= _build/root
+
+OS = $(shell uname -s | tr '[A-Z]' '[a-z]' | sed -e 's/darwin/macosx/g')
+ARCH = $(shell uname -m)
+
+ifeq ($(OS) $(ARCH),linux x86_64)
+XEN_INSTALL=install-xen
+XEN_BUILD=xen
+else
+XEN_BUILD=
+XEN_INSTALL=
+endif
+
+.PHONY: all install unix xen
+all: $(XEN_BUILD)
+	@ :
+
+unix:
+	env MIRAGEOS=unix ocamlbuild $(JOBS) block.cmxa
+
+xen:
+	env MIRAGEOS=xen ocamlbuild $(JOBS) block.cmxa
+
+clean:
+	ocamlbuild -clean
+

lib/block/direct/_tags

@@ -0,0 +1,2 @@
+<*.ml>: for-pack(Block)
+"rO.ml": pa_lwt

lib/block/direct/block.mlpack

@@ -0,0 +1 @@
+RO

lib/block/direct/myocamlbuild.ml

@@ -0,0 +1,38 @@
+open Ocamlbuild_plugin
+open Command
+
+let sf = Printf.sprintf
+let lib p x =
+  try
+    sf "%s/%s/%s" (Sys.getenv "MIRAGELIB") p x
+  with Not_found ->
+    sf "../../../../%s/_build/%s" p x
+
+let mplc =
+  try
+    sf "%s/../bin/mplc" (Sys.getenv "MIRAGELIB") 
+  with Not_found ->
+    "../../../../../tools/mpl/mplc" 
+
+let stdlib = lib "std"
+(* Set the build directory to reflect the OS chosen,
+   as they do not have compatible interfaces *)
+let os = try Sys.getenv "MIRAGEOS" with Not_found -> "unix"
+let oslib =
+  Options.build_dir := "_build/"^os;
+  lib "os" os
+
+let _ = dispatch begin function
+  | After_rules ->
+
+    (* do not compile and pack with the standard lib, and point to right OS module *)
+    flag ["ocaml"; "compile"] & S [A"-annot"; A"-I"; A (stdlib "lib"); A"-nostdlib"; A"-I"; A oslib];
+    flag ["ocaml"; "pack"   ] & S [A"-I"; A (stdlib "lib"); A"-nostdlib"];
+    pflag ["ocaml"; "pack"] "for-pack" (fun param -> S [A "-for-pack"; A param]);
+
+    (* use pa_lwt syntax extension if needed *)
+    flag ["ocaml"; "compile" ; "pa_lwt"] & S[A"-pp"; A(sf "camlp4o -I %s pa_lwt.cma" (stdlib "syntax"))];
+    flag ["ocaml"; "ocamldep"; "pa_lwt"] & S[A"-pp"; A(sf "camlp4o -I %s pa_lwt.cma" (stdlib "syntax"))];
+
+  | _ -> ()
+end

lib/block/direct/rO.ml

@@ -0,0 +1,95 @@
+(*
+ * Copyright (c) 2011 Anil Madhavapeddy <anil@recoil.org>
+ *
+ * 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.
+ *)
+
+(* A simple read-only block filesystem *)
+open Lwt
+open Printf
+
+type file = {
+  name: string;
+  offset: int64;
+  len: int64;
+}
+
+type t = {
+  vbd: OS.Blkif.t;
+  files: (string, file) Hashtbl.t;
+}
+
+let create vbd =
+  let files = Hashtbl.create 7 in
+  let rec read_page off =
+    lwt v = OS.Blkif.read_page vbd off in
+    let rec parse_page num =
+      let loff = num * 512 in
+      match OS.Istring.View.to_uint32_be v loff with
+      |0xDEADBEEFl -> begin
+        let offset = OS.Istring.View.to_uint64_be v (loff+4) in
+        let len = OS.Istring.View.to_uint64_be v (loff+12) in
+        let namelen = OS.Istring.View.to_uint32_be v (loff+20) in
+        let name = OS.Istring.View.to_string v (loff+24) (Int32.to_int namelen) in
+        if Int64.rem len 512L <> 0L then
+          fail (Failure "unaligned length file found")
+        else begin
+          Hashtbl.add files name { name; offset; len };
+          printf "Read file: %s %Lu[%Lu]\n%!" name offset len;
+          if num = 7 then
+            read_page (Int64.add off 8L)
+          else
+            parse_page (num+1)
+        end
+      end
+      |_ -> return ()
+    in
+    parse_page 0 in
+  read_page 0L >>
+  return { vbd; files }
+
+exception Not_found
+
+(* Read directly from the disk, no caching *)
+let read t filename =
+  try
+    let file = Hashtbl.find t.files filename in
+    (* File length is guaranteed to be sector aligned by the construction
+       tool, and we assume sector size = 512 bytes in this function *)
+    let sectors = Int64.div file.len 512L in
+    (* Assuming a sector size of 512, we can read a maximum of 
+       11 * 8 512-byte sectors (44KB) per scatter-gather request *)
+    let cur_seg = ref None in
+    let pos = ref 0L in
+    Some (Lwt_stream.from (fun () ->
+      (* Check if we have an active segment *)
+      match !cur_seg with
+      |Some (idx, arr) ->
+        (* Traversing an existing segment, so get next in element *)
+        let r = arr.(idx) in
+        cur_seg := if idx < Array.length arr - 1 then Some (idx+1, arr) else None;
+        return  (Some r)
+      |None ->
+        if !pos >= sectors then
+          return None (* EOF *)
+        else begin
+          (* Need to retrieve more data *)
+          let need_sectors = min 88L (Int64.sub sectors !pos) in
+          lwt arr = OS.Blkif.read_512 t.vbd !pos need_sectors in
+          pos := Int64.add !pos need_sectors;
+          if Array.length arr > 1 then
+            cur_seg := Some (1, arr);
+          return (Some arr.(0));
+        end
+    ))
+  with Not_found -> None

lib/cow/Makefile

@@ -17,7 +17,7 @@ all: syntax unix-direct unix-socket $(XEN_BUILD)
 	@ :
 
 syntax: syntax/xml/xml.ml syntax/html/xhtml.ml syntax/json/json.ml
-	ocamlbuild -I syntax syntax.otarget
+	ocamlbuild $(JOBS) -I syntax syntax.otarget
 
 syntax/xml/xml.ml:
 	@cd syntax/xml && ln -nsf ../../lib/xml.ml .
@@ -29,12 +29,12 @@ syntax/json/json.ml:
 	@cd syntax/json && ln -nsf ../../lib/json.ml .
 
 unix-%: 
-	MIRAGEOS=unix MIRAGEFLOW=$* ocamlbuild -I syntax syntax.otarget
-	MIRAGEOS=unix MIRAGEFLOW=$* ocamlbuild lib.otarget
+	MIRAGEOS=unix MIRAGEFLOW=$* ocamlbuild $(JOBS) -I syntax syntax.otarget
+	MIRAGEOS=unix MIRAGEFLOW=$* ocamlbuild $(JOBS) lib.otarget
 
 xen-%: syntax
-	MIRAGEOS=xen MIRAGEFLOW=$* ocamlbuild -I syntax syntax.otarget
-	MIRAGEOS=xen MIRAGEFLOW=$* ocamlbuild lib.otarget
+	MIRAGEOS=xen MIRAGEFLOW=$* ocamlbuild $(JOBS) -I syntax syntax.otarget
+	MIRAGEOS=xen MIRAGEFLOW=$* ocamlbuild $(JOBS) lib.otarget
 
 test: syntax lib
 	rm -rf tests/_build

lib/cow/lib/twitter.ml

@@ -15,6 +15,7 @@
 open Lwt
 
 (* XXX: no DNS client yet *)
+let twitter_ip = Net.Nettypes.ipv4_addr_of_tuple (168,143,162,45)
 let twitter = "http://168.143.162.45"
 module User = struct
 
@@ -37,19 +38,20 @@ module Status = struct
       t list
   with json
 
+(*
   let user_timeline mgr ?screen_name () =
     let filter = match screen_name with
       | Some n -> "?screen_name=" ^ n
       | None   -> "" in
-    let uri = Printf.sprintf "%s/1/statuses/user_timeline.json%s" twitter filter in
-    let headers =
+    let req_url = Printf.sprintf "%s/1/statuses/user_timeline.json%s" twitter filter in
+    let req_headers =
       ["Host", "api.twitter.com";
        "Connection", "keep-alive" ] in
-    lwt _, body_t = Http.Client.get mgr ~headers uri in
-    (* TODO use istring directly *)
-    lwt body = map OS.Istring.View.ts_to_string body_t in
+    let req = { req_meth=`GET; req_url; req_headers; req_body=None } in
+    lwt res = request mgr (twitter_ip,80) req in
+    lwt body = OS.Istring.View.(ts_of_stream res.res_body >|= ts_to_string) in
     let str = Json.of_string body in
     return (t_list_of_json str)
-
+*)
 end
 

lib/cow/lib/twitter.mli

@@ -38,5 +38,5 @@ module Status : sig
   val json_of_t_list : t list -> Json.t
   val t_list_of_json : Json.t -> t list
 
-  val user_timeline : Net.Flow.TCPv4.mgr -> ?screen_name:string -> unit -> t list Lwt.t
+(*  val user_timeline : Http.Rpc.TCPv4.mgr -> ?screen_name:string -> unit -> t list Lwt.t *)
 end

lib/cow/myocamlbuild.ml

@@ -91,7 +91,7 @@ module Flags = struct
   let pa_ulex = camlp4 pa_ulex_deps
   let pa_cow  = camlp4 pa_cow_deps
 
-  let stdlib  = [ A"-nostdlib"; A"-I"; A std_lib; A "-I"; A os_lib; A "-I"; A net_lib ]
+  let stdlib  = [ A"-nostdlib"; A"-I"; A std_lib; A "-I"; A os_lib; A "-I"; A net_lib; A "-I"; A http_lib ]
   let dyntype = [ A"-I"; A dyntype_lib ]
   let ulex    = [ A"-I"; A std_lib ]
   let cow     = [ A"-I"; A "lib" ]

lib/dns/Makefile

@@ -15,10 +15,10 @@ all: unix-direct unix-socket $(XEN_BUILD)
 	@ :
 
 unix-%:
-	env MIRAGEOS=unix MIRAGEFLOW=$* ocamlbuild dns.cmxa
+	env MIRAGEOS=unix MIRAGEFLOW=$* ocamlbuild $(JOBS) dns.cmxa
 
 xen-%:
-	env MIRAGEOS=xen MIRAGEFLOW=$* ocamlbuild dns.cmxa
+	env MIRAGEOS=xen MIRAGEFLOW=$* ocamlbuild $(JOBS) dns.cmxa
 
 clean:
 	ocamlbuild -clean

lib/dns/server.ml

@@ -23,8 +23,6 @@ module DR = Dnsrr
 
 let dnstrie = DL.(state.db.trie)
 
-(* Specialise dns packet to a smaller closure *)
-
 let log (addr,port) (dnsq:Packet.Questions.o) =
   printf "%.0f: %s %s %s (%s:%d)\n%!" (OS.Clock.time())
     (String.concat "." dnsq#qname)
@@ -44,12 +42,11 @@ let get_answer (qname,qtype) id =
 
 let listen mgr src ~zonebuf =
   Dnsserver.load_zone [] zonebuf;
-  Net.Flow.UDPv4.(recv mgr src 
+  Net.Datagram.UDPv4.(recv mgr src 
     (fun dst env ->
       Mpl_dns_label.init_unmarshal env;
       let d = Packet.unmarshal env in
       let q = d#questions.(0) in
-      log dst q;
       let r = get_answer (q#qname, q#qtype) d#id in
       let dnsfn env =
         Mpl_dns_label.init_marshal env;

lib/dns/server.mli

@@ -16,4 +16,4 @@
 
 (* Listening thread that parses the zonebuf (in BIND zonefile format)
    and replies to clients on the specified Flow *)
-val listen : Net.Flow.UDPv4.mgr -> Net.Flow.UDPv4.src -> zonebuf:string -> unit Lwt.t
+val listen : Net.Datagram.UDPv4.mgr -> Net.Datagram.UDPv4.src -> zonebuf:string -> unit Lwt.t

lib/dyntype/Makefile

@@ -5,13 +5,13 @@ all: lib syntax
 	@ :
 
 lib:
-	ocamlbuild lib/dyntype.cmx
+	ocamlbuild $(JOBS) lib/dyntype.cmx
 
 syntax/dyntype.ml:
 	@cd syntax && ln -nfs ../lib/dyntype.ml .
 
 syntax: syntax/dyntype.ml
-	ocamlbuild syntax.otarget
+	ocamlbuild $(JOBS) syntax.otarget
 
 TARGETDIR=$(DESTDIR)$(PREFIX)/mirage/dyntype
 install:

lib/http/Makefile

@@ -15,10 +15,10 @@ all: unix-socket unix-direct $(XEN_BUILD)
 	@ :
 
 unix-%:
-	env MIRAGEOS=unix MIRAGEFLOW=$* ocamlbuild http.cmxa
+	env MIRAGEOS=unix MIRAGEFLOW=$* ocamlbuild $(JOBS) http.cmxa
 
 xen-%:
-	env MIRAGEOS=xen MIRAGEFLOW=$* ocamlbuild http.cmxa
+	env MIRAGEOS=xen MIRAGEFLOW=$* ocamlbuild $(JOBS) http.cmxa
 
 clean:
 	ocamlbuild -clean

lib/http/_tags

@@ -1,2 +1,2 @@
 <*.cmx> and not "http.cmx": for-pack(Http)
-"server.ml" or "message.ml" or "misc.ml" or "parser.ml" or "request.ml" or "client.ml": pa_lwt
+"server.ml" or "message.ml" or "misc.ml" or "parser.ml" or "request.ml" or "client.ml" or "manager.ml" or "rpc.ml": pa_lwt