Browse files

Import kFreeBSDified version of mirage-net.

  • Loading branch information...
1 parent a51477b commit 0ff5b2cd7ab0975e3f2ee1bd89f8e5dbf028b102 @pgj committed Aug 31, 2012
Showing with 5,722 additions and 0 deletions.
  1. +5 −0 packages/mirage-net/META
  2. +11 −0 packages/mirage-net/Makefile
  3. +9 −0 packages/mirage-net/_tags
  4. +191 −0 packages/mirage-net/lib/arp.ml
  5. +32 −0 packages/mirage-net/lib/arp.mli
  6. +280 −0 packages/mirage-net/lib/channel.ml
  7. +55 −0 packages/mirage-net/lib/channel.mli
  8. +19 −0 packages/mirage-net/lib/checksum.ml
  9. +21 −0 packages/mirage-net/lib/checksum.mli
  10. +34 −0 packages/mirage-net/lib/config.ml
  11. +20 −0 packages/mirage-net/lib/config.mli
  12. +45 −0 packages/mirage-net/lib/datagram.ml
  13. +22 −0 packages/mirage-net/lib/datagram.mli
  14. +223 −0 packages/mirage-net/lib/dhcp/client.ml
  15. +39 −0 packages/mirage-net/lib/dhcp/client.mli
  16. +2 −0 packages/mirage-net/lib/dhcp/dhcp.mlpack
  17. +425 −0 packages/mirage-net/lib/dhcp/option.ml
  18. +110 −0 packages/mirage-net/lib/dhcp/option.mli
  19. +87 −0 packages/mirage-net/lib/ethif.ml
  20. +42 −0 packages/mirage-net/lib/ethif.mli
  21. +127 −0 packages/mirage-net/lib/flow.ml
  22. +49 −0 packages/mirage-net/lib/flow.mli
  23. +59 −0 packages/mirage-net/lib/icmp.ml
  24. +21 −0 packages/mirage-net/lib/icmp.mli
  25. +4 −0 packages/mirage-net/lib/ip/iP.mlpack
  26. +189 −0 packages/mirage-net/lib/ipv4.ml
  27. +37 −0 packages/mirage-net/lib/ipv4.mli
  28. +190 −0 packages/mirage-net/lib/manager.ml
  29. +47 −0 packages/mirage-net/lib/manager.mli
  30. +14 −0 packages/mirage-net/lib/net.mlpack
  31. +177 −0 packages/mirage-net/lib/nettypes.ml
  32. +119 −0 packages/mirage-net/lib/nettypes.mli
  33. +42 −0 packages/mirage-net/lib/resolve.ml
  34. +140 −0 packages/mirage-net/lib/tcp/ack.ml
  35. +29 −0 packages/mirage-net/lib/tcp/ack.mli
  36. +36 −0 packages/mirage-net/lib/tcp/notes.md
  37. +130 −0 packages/mirage-net/lib/tcp/options.ml
  38. +29 −0 packages/mirage-net/lib/tcp/options.mli
  39. +679 −0 packages/mirage-net/lib/tcp/pcb.ml
  40. +46 −0 packages/mirage-net/lib/tcp/pcb.mli
  41. +360 −0 packages/mirage-net/lib/tcp/segment.ml
  42. +52 −0 packages/mirage-net/lib/tcp/segment.mli
  43. +51 −0 packages/mirage-net/lib/tcp/sequence.ml
  44. +48 −0 packages/mirage-net/lib/tcp/sequence.mli
  45. +78 −0 packages/mirage-net/lib/tcp/sliding_window.ml
  46. +37 −0 packages/mirage-net/lib/tcp/sliding_window.mli
  47. +153 −0 packages/mirage-net/lib/tcp/state.ml
  48. +49 −0 packages/mirage-net/lib/tcp/state.mli
  49. +11 −0 packages/mirage-net/lib/tcp/tcp.mlpack
  50. +58 −0 packages/mirage-net/lib/tcp/tcptimer.ml
  51. +26 −0 packages/mirage-net/lib/tcp/tcptimer.mli
  52. +303 −0 packages/mirage-net/lib/tcp/user_buffer.ml
  53. +39 −0 packages/mirage-net/lib/tcp/user_buffer.mli
  54. +232 −0 packages/mirage-net/lib/tcp/window.ml
  55. +58 −0 packages/mirage-net/lib/tcp/window.mli
  56. +131 −0 packages/mirage-net/lib/tcp/wire.ml
  57. +79 −0 packages/mirage-net/lib/tcp/wire.mli
  58. +91 −0 packages/mirage-net/lib/udp.ml
  59. +29 −0 packages/mirage-net/lib/udp.mli
  60. +1 −0 packages/mirage-net/myocamlbuild.ml
View
5 packages/mirage-net/META
@@ -0,0 +1,5 @@
+version = "0.1"
+description = "TCP/IP networking stack"
+archive(byte) = "net.cma"
+archive(native) = "net.cmxa"
+requires = "mirage-platform"
View
11 packages/mirage-net/Makefile
@@ -0,0 +1,11 @@
+
+LIBNAME= mirage-net
+
+_SRCS!= ls lib/*.ml
+_SRCS_DHCP!= ls lib/dhcp/*.ml
+_SRCS_TCP!= ls lib/tcp/*.ml
+
+SRCS= ${_SRCS} ${_SRCS_DHCP} ${_SRCS_TCP}
+MLLIB= lib/net.cma lib/net.cmxa lib/net.a
+
+.include "${.CURDIR}/../bsd.mirage.mk"
View
9 packages/mirage-net/_tags
@@ -0,0 +1,9 @@
+<lib/*>: for-pack(Net), use_custom_stdlib, use_lwt, use_os, use_cstruct
+<lib/dhcp/*>: for-pack(Net.Dhcp), use_custom_stdlib, use_lwt, use_os, use_cstruct
+<lib/tcp/*>: for-pack(Net.Tcp), use_custom_stdlib, use_lwt, use_os, use_cstruct
+<lib/dhcp/dhcp.*>: for-repack(Net)
+<lib/tcp/tcp.*>: for-repack(Net)
+"lib": include
+"lib/tcp": include
+"lib/dhcp": include
+true: camlp4of
View
191 packages/mirage-net/lib/arp.ml
@@ -0,0 +1,191 @@
+(*
+ * Copyright (c) 2010-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.
+ *
+ *)
+
+open Lwt
+open Nettypes
+open Printf
+
+(* TODO implement the full ARP state machine (pending, failed, timer thread, etc) *)
+type entry =
+ | Incomplete of ethernet_mac Lwt_condition.t
+ | Verified of ethernet_mac
+
+type t = {
+ get_etherbuf: unit -> OS.Io_page.t Lwt.t;
+ output: OS.Io_page.t -> unit Lwt.t;
+ get_mac: unit -> ethernet_mac;
+ cache: (ipv4_addr, entry) Hashtbl.t;
+ mutable bound_ips: ipv4_addr list;
+ }
+
+cstruct arp {
+ uint8_t dst[6];
+ uint8_t src[6];
+ uint16_t ethertype;
+ uint16_t htype;
+ uint16_t ptype;
+ uint8_t hlen;
+ uint8_t plen;
+ uint16_t op;
+ uint8_t sha[6];
+ uint32_t spa;
+ uint8_t tha[6];
+ uint32_t tpa
+} as big_endian
+
+cenum op {
+ Op_request = 1;
+ Op_reply
+} as uint16_t
+
+(* Prettyprint cache contents *)
+let prettyprint t =
+ printf "ARP info:\n";
+ Hashtbl.iter (fun ip entry ->
+ printf "%s -> %s\n%!"
+ (ipv4_addr_to_string ip)
+ (match entry with
+ | Incomplete _ -> "I"
+ | Verified mac -> sprintf "V(%s)" (ethernet_mac_to_string mac)
+ )
+ ) t.cache
+
+(* Input handler for an ARP packet, registered through attach() *)
+let rec input t frame =
+ match get_arp_op frame with
+ |1 -> (* Request *)
+ (* Received ARP request, check if we can satisfy it from
+ our own IPv4 list *)
+ let req_ipv4 = ipv4_addr_of_uint32 (get_arp_tpa frame) in
+ printf "ARP: who-has %s?\n%!" (ipv4_addr_to_string req_ipv4);
+ if List.mem req_ipv4 t.bound_ips then begin
+ (* We own this IP, so reply with our MAC *)
+ let sha = t.get_mac () in
+ let tha = ethernet_mac_of_bytes (copy_arp_sha frame) in
+ let spa = ipv4_addr_of_uint32 (get_arp_tpa frame) in (* the requested address *)
+ let tpa = ipv4_addr_of_uint32 (get_arp_spa frame) in (* the requesting host IPv4 *)
+ output t { op=`Reply; sha; tha; spa; tpa }
+ end else return ()
+ |2 -> (* Reply *)
+ let spa = ipv4_addr_of_uint32 (get_arp_spa frame) in
+ let sha = ethernet_mac_of_bytes (copy_arp_sha frame) in
+ printf "ARP: updating %s -> %s\n%!"
+ (ipv4_addr_to_string spa) (ethernet_mac_to_string sha);
+ (* If we have pending entry, notify the waiters that answer is ready *)
+ if Hashtbl.mem t.cache spa then begin
+ match Hashtbl.find t.cache spa with
+ |Incomplete cond -> Lwt_condition.broadcast cond sha
+ |_ -> ()
+ end;
+ Hashtbl.replace t.cache spa (Verified sha);
+ return ()
+ |n ->
+ printf "ARP: Unknown message %d ignored\n%!" n;
+ return ()
+
+and output t arp =
+ (* Obtain a buffer to write into *)
+ lwt buf = t.get_etherbuf () in
+ (* Write the ARP packet *)
+ let dmac = ethernet_mac_to_bytes arp.tha in
+ let smac = ethernet_mac_to_bytes arp.sha in
+ let spa = ipv4_addr_to_uint32 arp.spa in
+ let tpa = ipv4_addr_to_uint32 arp.tpa in
+ let op =
+ match arp.op with
+ |`Request -> 1
+ |`Reply -> 2
+ |`Unknown n -> n
+ in
+ set_arp_dst dmac 0 buf;
+ set_arp_src smac 0 buf;
+ set_arp_ethertype buf 0x0806; (* ARP *)
+ set_arp_htype buf 1;
+ set_arp_ptype buf 0x0800; (* IPv4 *)
+ set_arp_hlen buf 6; (* ethernet mac size *)
+ set_arp_plen buf 4; (* ipv4 size *)
+ set_arp_op buf op;
+ set_arp_sha smac 0 buf;
+ set_arp_spa buf spa;
+ set_arp_tha dmac 0 buf;
+ set_arp_tpa buf tpa;
+ (* Resize buffer to sizeof arp packet *)
+ let buf = Cstruct.sub buf 0 sizeof_arp in
+ t.output buf
+
+(* Send a gratuitous ARP for our IP addresses *)
+let output_garp t =
+ let tha = ethernet_mac_broadcast in
+ let sha = t.get_mac () in
+ let tpa = ipv4_blank in
+ Lwt_list.iter_s (fun spa ->
+ printf "ARP: sending gratuitous from %s\n%!" (ipv4_addr_to_string spa);
+ output t { op=`Reply; tha; sha; tpa; spa }
+ ) t.bound_ips
+
+(* Send a query for a particular IP *)
+let output_probe t tpa =
+ printf "ARP: transmitting probe -> %s\n%!" (ipv4_addr_to_string tpa);
+ let tha = ethernet_mac_broadcast in
+ let sha = t.get_mac () in
+ (* Source protocol address, pick one of our IP addresses *)
+ let spa = match t.bound_ips with
+ | hd::tl -> hd | [] -> ipv4_blank in
+ output t { op=`Request; tha; sha; tpa; spa }
+
+let get_ips t = t.bound_ips
+
+(* Set the bound IP address list, which will xmit a GARP packet also *)
+let set_ips t ips =
+ t.bound_ips <- ips;
+ output_garp t
+
+let add_ip t ip =
+ if not (List.mem ip t.bound_ips) then
+ set_ips t (ip :: t.bound_ips)
+ else return ()
+
+let remove_ip t ip =
+ if List.mem ip t.bound_ips then
+ set_ips t (List.filter ((<>) ip) t.bound_ips)
+ else return ()
+
+(* Query the cache for an ARP entry, which may result in the sender sleeping
+ waiting for a response *)
+let query t ip =
+ if Hashtbl.mem t.cache ip then (
+ match Hashtbl.find t.cache ip with
+ | Incomplete cond ->
+ (* printf "ARP query: %s -> [incomplete]\n%!" (ipv4_addr_to_string ip); *)
+ Lwt_condition.wait cond
+ | Verified mac ->
+ (* printf "ARP query: %s -> %s\n%!"
+ (ipv4_addr_to_string ip) (ethernet_mac_to_string mac); *)
+ return mac
+ ) else (
+ let cond = Lwt_condition.create () in
+ (* printf "ARP query: %s -> [probe]\n%!" (ipv4_addr_to_string ip); *)
+ Hashtbl.add t.cache ip (Incomplete cond);
+ (* First request, so send a query packet *)
+ lwt () = output_probe t ip in
+ Lwt_condition.wait cond
+ )
+
+let create ~get_etherbuf ~output ~get_mac =
+ let cache = Hashtbl.create 7 in
+ let bound_ips = [] in
+ { output; get_mac; cache; bound_ips; get_etherbuf }
View
32 packages/mirage-net/lib/arp.mli
@@ -0,0 +1,32 @@
+(*
+ * Copyright (c) 2010-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.
+ *
+ *)
+
+open Nettypes
+open Printf
+
+type t
+
+val set_ips: t -> ipv4_addr list -> unit Lwt.t
+val get_ips: t -> ipv4_addr list
+val add_ip: t -> ipv4_addr -> unit Lwt.t
+val remove_ip: t -> ipv4_addr -> unit Lwt.t
+
+val input: t -> OS.Io_page.t -> unit Lwt.t
+val query: t -> ipv4_addr -> ethernet_mac Lwt.t
+
+val create: get_etherbuf:(unit -> OS.Io_page.t Lwt.t) ->
+ output:(OS.Io_page.t -> unit Lwt.t) -> get_mac:(unit -> ethernet_mac) -> t
View
280 packages/mirage-net/lib/channel.ml
@@ -0,0 +1,280 @@
+(*
+ * 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.
+ *)
+
+(* Buffered reading and writing over the flow API *)
+open Lwt
+open Printf
+open Nettypes
+
+module Make(Flow:FLOW) :
+ (CHANNEL with type src = Flow.src
+ and type dst = Flow.dst
+ and type mgr = Flow.mgr) = struct
+
+ type flow = Flow.t
+ type src = Flow.src
+ type dst = Flow.dst
+ type mgr = Flow.mgr
+
+ type t = {
+ flow: flow;
+ mutable ibuf: OS.Io_page.t option; (* Queue of incoming buf *)
+ mutable obufq: OS.Io_page.t list; (* Queue of completed writebuf *)
+ mutable obuf: OS.Io_page.t option; (* Active write buffer *)
+ mutable opos: int; (* Position in active write buffer *)
+ abort_t: unit Lwt.t;
+ abort_u: unit Lwt.u;
+ }
+
+ exception Closed
+
+ let create flow =
+ let ibuf = None in
+ let obufq = [] in
+ let obuf = None in
+ let opos = 0 in
+ let abort_t, abort_u = Lwt.task () in
+ { ibuf; obuf; flow; obufq; opos; abort_t; abort_u }
+
+ let ibuf_refill t =
+ match_lwt Flow.read t.flow with
+ |Some buf ->
+ t.ibuf <- Some buf;
+ return ()
+ |None ->
+ fail Closed
+
+ let rec get_ibuf t =
+ match t.ibuf with
+ |None -> ibuf_refill t >> get_ibuf t
+ |Some buf when Cstruct.len buf = 0 -> ibuf_refill t >> get_ibuf t
+ |Some buf -> return buf
+
+ (* Read one character from the input channel *)
+ let read_char t =
+ lwt buf = get_ibuf t in
+ let c = Cstruct.get_char buf 0 in
+ t.ibuf <- Some (Cstruct.shift buf 1);
+ return c
+
+ (* Read up to len characters from the input channel
+ and at most a full view. If not specified, read all *)
+ let read_some ?len t =
+ lwt buf = get_ibuf t in
+ let avail = Cstruct.len buf in
+ let len = match len with |Some len -> len |None -> avail in
+ if len < avail then begin
+ let hd,tl = Cstruct.split buf len in
+ t.ibuf <- Some tl;
+ return hd
+ end else begin
+ t.ibuf <- None;
+ return buf
+ end
+
+ (* Read up to len characters from the input channel as a
+ stream (and read all available if no length specified *)
+ let read_stream ?len t =
+ Lwt_stream.from (fun () ->
+ try_lwt
+ lwt v = read_some ?len t in
+ return (Some v)
+ with Closed ->
+ return None
+ )
+
+ (* Read until a character is found *)
+ let read_until t ch =
+ lwt buf = get_ibuf t in
+ let len = Cstruct.len buf in
+ let rec scan off =
+ if off = len then None else begin
+ if Cstruct.get_char buf off = ch then
+ Some off else scan (off+1)
+ end
+ in
+ match scan 0 with
+ |None -> (* not found, return what we have until EOF *)
+ t.ibuf <- None;
+ return (false, buf)
+ |Some off -> (* found, so split the buffer *)
+ let hd = Cstruct.sub_buffer buf 0 off in
+ t.ibuf <- Some (Cstruct.shift buf (off+1));
+ return (true, hd)
+
+ (* This reads a line of input, which is terminated either by a CRLF
+ sequence, or the end of the channel (which counts as a line).
+ @return Returns a stream of views that terminates at EOF.
+ @raise Closed to signify EOF *)
+ let read_line t =
+ let rec get acc =
+ match_lwt read_until t '\n' with
+ |(false, v) ->
+ get (v :: acc)
+ |(true, v) -> begin
+ (* chop the CR if present *)
+ let vlen = Cstruct.len v in
+ let v =
+ if vlen > 0 && (Cstruct.get_char v (vlen-1) = '\r') then
+ Cstruct.sub v 0 (vlen-1) else v
+ in
+ return (v :: acc)
+ end
+ in
+ get [] >|= List.rev
+
+ (* Output functions *)
+
+ let alloc_obuf t =
+ let buf = OS.Io_page.get () in
+ t.obuf <- Some buf;
+ t.opos <- 0;
+ buf
+
+ (* Queue the active write buffer onto the write queue, resizing the
+ * view if necessary to the correct size. *)
+ let queue_obuf t =
+ match t.obuf with
+ |None -> ()
+ |Some buf when Cstruct.len buf = t.opos -> (* obuf is full *)
+ t.obufq <- buf :: t.obufq;
+ t.obuf <- None
+ |Some buf when t.opos = 0 -> (* obuf wasnt ever used, so discard *)
+ t.obuf <- None
+ |Some buf -> (* partially filled obuf, so resize *)
+ let buf = Cstruct.sub buf 0 t.opos in
+ t.obufq <- buf :: t.obufq;
+ t.obuf <- None
+
+ (* Get an active output buffer, which will allocate it if needed.
+ * The position to write into is stored in t.opos *)
+ let get_obuf t =
+ match t.obuf with
+ |None -> alloc_obuf t
+ |Some buf when Cstruct.len buf = t.opos -> queue_obuf t; alloc_obuf t
+ |Some buf -> buf
+
+ (* Non-blocking character write, since Io page allocation never blocks.
+ * That may change in the future... *)
+ let write_char t ch =
+ let buf = get_obuf t in
+ Cstruct.set_char buf t.opos ch;
+ t.opos <- t.opos + 1
+
+ (* This is zero copy; flush current IO page and queue up the incoming
+ * buffer directly. *)
+ let write_buffer t buf =
+ queue_obuf t;
+ t.obufq <- buf :: t.obufq
+
+ let rec write_string t s off len =
+ let buf = get_obuf t in
+ let avail = Cstruct.len buf - t.opos in
+ if avail < len then begin
+ Cstruct.set_buffer s off buf t.opos avail;
+ t.opos <- t.opos + avail;
+ write_string t s (off+avail) (len-avail)
+ end else begin
+ Cstruct.set_buffer s off buf t.opos len;
+ t.opos <- t.opos + len
+ end
+
+ let write_line t buf =
+ write_string t buf 0 (String.length buf);
+ write_char t '\n'
+
+ let rec flush t =
+ queue_obuf t;
+ let l = List.rev t.obufq in
+ t.obufq <- [];
+ Flow.writev t.flow l
+
+ let close t =
+ flush t >>
+ Flow.close t.flow
+
+ let connect mgr ?src dst fn =
+ Flow.connect mgr ?src dst (fun f -> fn (create f))
+
+ let listen mgr src fn =
+ Flow.listen mgr src (fun dst f -> fn dst (create f))
+
+end
+
+module TCPv4 = Make(Flow.TCPv4)
+module Shmem = Make(Flow.Shmem)
+
+type t =
+ | TCPv4 of TCPv4.t
+ | Shmem of Shmem.t
+
+let read_char = function
+ | TCPv4 t -> TCPv4.read_char t
+ | Shmem t -> Shmem.read_char t
+
+let read_until = function
+ | TCPv4 t -> TCPv4.read_until t
+ | Shmem t -> Shmem.read_until t
+
+let read_some ?len = function
+ | TCPv4 t -> TCPv4.read_some ?len t
+ | Shmem t -> Shmem.read_some ?len t
+
+let read_stream ?len = function
+ | TCPv4 t -> TCPv4.read_stream ?len t
+ | Shmem t -> Shmem.read_stream ?len t
+
+let read_line = function
+ | TCPv4 t -> TCPv4.read_line t
+ | Shmem t -> Shmem.read_line t
+
+let write_char = function
+ | TCPv4 t -> TCPv4.write_char t
+ | Shmem t -> Shmem.write_char t
+
+let write_string = function
+ | TCPv4 t -> TCPv4.write_string t
+ | Shmem t -> Shmem.write_string t
+
+let write_buffer = function
+ | TCPv4 t -> TCPv4.write_buffer t
+ | Shmem t -> Shmem.write_buffer t
+
+let write_line = function
+ | TCPv4 t -> TCPv4.write_line t
+ | Shmem t -> Shmem.write_line t
+
+let flush = function
+ | TCPv4 t -> TCPv4.flush t
+ | Shmem t -> Shmem.flush t
+
+let close = function
+ | TCPv4 t -> TCPv4.close t
+ | Shmem t -> Shmem.close t
+
+let connect mgr = function
+ |`TCPv4 (src, dst, fn) ->
+ TCPv4.connect mgr ?src dst (fun t -> fn (TCPv4 t))
+ |`Shmem (src, dst, fn) ->
+ Shmem.connect mgr ?src dst (fun t -> fn (Shmem t))
+ |_ -> fail (Failure "unknown protocol")
+
+let listen mgr = function
+ |`TCPv4 (src, fn) ->
+ TCPv4.listen mgr src (fun dst t -> fn dst (TCPv4 t))
+ |`Shmem (src, fn) ->
+ Shmem.listen mgr src (fun dst t -> fn dst (Shmem t))
+ |_ -> fail (Failure "unknown protocol")
View
55 packages/mirage-net/lib/channel.mli
@@ -0,0 +1,55 @@
+(*
+ * 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.
+ *)
+
+open Nettypes
+
+module TCPv4 : CHANNEL with
+ type src = ipv4_src
+ and type dst = ipv4_dst
+ and type mgr = Manager.t
+
+module Shmem : CHANNEL with
+ type src = peer_uid
+ and type dst = peer_uid
+ and type mgr = Manager.t
+
+type t
+
+val read_char: t -> char Lwt.t
+val read_some: ?len:int -> t -> OS.Io_page.t Lwt.t
+val read_until: t -> char -> (bool * OS.Io_page.t) Lwt.t
+val read_stream: ?len:int -> t -> OS.Io_page.t Lwt_stream.t
+val read_line: t -> OS.Io_page.t list Lwt.t
+
+val write_char : t -> char -> unit
+val write_string : t -> string -> int -> int -> unit
+val write_buffer : t -> OS.Io_page.t -> unit
+val write_line : t -> string -> unit
+
+val flush : t -> unit Lwt.t
+val close : t -> unit Lwt.t
+
+val connect :
+ Manager.t -> [>
+ | `Shmem of peer_uid option * peer_uid * (t -> 'a Lwt.t)
+ | `TCPv4 of ipv4_src option * ipv4_dst * (t -> 'a Lwt.t)
+ ] -> 'a Lwt.t
+
+val listen :
+ Manager.t -> [>
+ | `Shmem of peer_uid * (peer_uid -> t -> unit Lwt.t)
+ | `TCPv4 of ipv4_src * (ipv4_dst -> t -> unit Lwt.t)
+ ] -> unit Lwt.t
View
19 packages/mirage-net/lib/checksum.ml
@@ -0,0 +1,19 @@
+(*
+ * Copyright (c) 2010-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.
+ *)
+
+(** One's complement checksum, RFC1071 *)
+external ones_complement: OS.Io_page.t -> int -> int = "caml_ones_complement_checksum"
+external ones_complement_list: OS.Io_page.t list -> int = "caml_ones_complement_checksum_list"
View
21 packages/mirage-net/lib/checksum.mli
@@ -0,0 +1,21 @@
+(*
+ * Copyright (c) 2010-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.
+ *)
+
+(** Checksum functions for TCP/IP *)
+
+(** One's complement checksum, RFC1071 *)
+external ones_complement: OS.Io_page.t -> int -> int = "caml_ones_complement_checksum"
+external ones_complement_list: OS.Io_page.t list -> int = "caml_ones_complement_checksum_list"
View
34 packages/mirage-net/lib/config.ml
@@ -0,0 +1,34 @@
+(*
+ * 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.
+ *)
+
+(** Configuration modes for interfaces.
+ Defaults to DHCP, and individual ids can be assigned static IPs *)
+
+(* For now, uncomment the one you want until we have a p4 syntax extension
+ which compiles in the correct set of options based on user choice *)
+
+(* Just use DHCP for the interface *)
+let t id =
+ `DHCP
+
+(* Static IPv4 address *)
+let t id =
+ let open Nettypes in
+ `IPv4 (
+ ipv4_addr_of_tuple (10l,0l,0l,2l),
+ ipv4_addr_of_tuple (255l,255l,255l,0l),
+ [ ipv4_addr_of_tuple (10l,0l,0l,1l) ]
+ )
View
20 packages/mirage-net/lib/config.mli
@@ -0,0 +1,20 @@
+(*
+ * 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.
+ *)
+
+(** Configuration modes for interfaces.
+ Defaults to DHCP, and individual ids can be assigned static IPs *)
+
+val t: OS.Netif.id -> [ `DHCP | `IPv4 of Nettypes.ipv4_addr * Nettypes.ipv4_addr * Nettypes.ipv4_addr list ]
View
45 packages/mirage-net/lib/datagram.ml
@@ -0,0 +1,45 @@
+(*
+ * 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.
+ *)
+
+open Lwt
+open Nettypes
+
+module UDPv4 = struct
+
+ type mgr = Manager.t
+ type src = ipv4_src
+ type dst = ipv4_dst
+ type msg = OS.Io_page.t
+
+ let send mgr ?src (dest_ip, dest_port) msg =
+ (* TODO: set src addr here also *)
+ let source_port = match src with
+ |None -> 37 (* XXX eventually random *)
+ |Some (_,p) -> p in
+ let udps = Manager.udpv4_of_addr mgr None in
+ (* TODO: select the right interface to route from *)
+ match udps with
+ |hd :: tl -> Udp.write hd ~dest_ip ~source_port ~dest_port msg
+ |[] -> Printf.printf "UDP: no route to send packet, discarding\n%!"; return ()
+
+ let recv mgr (src_addr, src_port) fn =
+ let udps = Manager.udpv4_of_addr mgr src_addr in
+ Lwt_list.iter_p (fun udp ->
+ Udp.listen udp src_port (fun ~src ~dst ~source_port pkt ->
+ fn (src,source_port) pkt
+ )
+ ) udps
+end
View
22 packages/mirage-net/lib/datagram.mli
@@ -0,0 +1,22 @@
+(*
+ * 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.
+ *)
+
+module UDPv4 : Nettypes.DATAGRAM with
+ type mgr = Manager.t
+ and type src = Nettypes.ipv4_src
+ and type dst = Nettypes.ipv4_dst
+ and type msg = OS.Io_page.t
+
View
223 packages/mirage-net/lib/dhcp/client.ml
@@ -0,0 +1,223 @@
+(*
+ * Copyright (c) 2006-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.
+ *
+ *)
+
+open Lwt
+open Printf
+open Nettypes
+
+type offer = {
+ ip_addr: ipv4_addr;
+ netmask: ipv4_addr option;
+ gateways: ipv4_addr list;
+ dns: ipv4_addr list;
+ lease: int32;
+ xid: int32;
+}
+
+type state =
+ | Disabled
+ | Request_sent of int32
+ | Offer_accepted of offer
+ | Lease_held of offer
+ | Shutting_down
+
+type t = {
+ udp: Udp.t;
+ ip: Ipv4.t;
+ mutable state: state;
+ new_offer: offer -> unit Lwt.t;
+}
+
+cstruct dhcp {
+ uint8_t op;
+ uint8_t htype;
+ uint8_t hlen;
+ uint8_t hops;
+ uint32_t xid;
+ uint16_t secs;
+ uint16_t flags;
+ uint32_t ciaddr;
+ uint32_t yiaddr;
+ uint32_t siaddr;
+ uint32_t giaddr;
+ uint8_t chaddr[16];
+ uint8_t sname[64];
+ uint8_t file[128];
+ uint32_t cookie
+} as big_endian
+
+cenum mode {
+ BootRequest = 1;
+ BootReply
+} as uint8_t
+
+(* Send a client broadcast packet *)
+let output_broadcast t ~xid ~yiaddr ~siaddr ~options =
+ lwt buf = Udp.get_writebuf ~dest_ip:ipv4_broadcast ~source_port:68 ~dest_port:67 t.udp in
+ set_dhcp_op buf (mode_to_int BootRequest);
+ set_dhcp_htype buf 1;
+ set_dhcp_hlen buf 6;
+ set_dhcp_hops buf 0;
+ set_dhcp_xid buf xid;
+ set_dhcp_secs buf 10; (* TODO dynamic timer *)
+ set_dhcp_flags buf 0;
+ set_dhcp_ciaddr buf 0l;
+ set_dhcp_yiaddr buf (ipv4_addr_to_uint32 yiaddr);
+ set_dhcp_siaddr buf (ipv4_addr_to_uint32 siaddr);
+ set_dhcp_giaddr buf 0l;
+ (* TODO add a pad/fill function in cstruct *)
+ set_dhcp_chaddr (ethernet_mac_to_bytes (Ipv4.mac t.ip) ^ (String.make 10 '\000')) 0 buf;
+ set_dhcp_sname (String.make 64 '\000') 0 buf;
+ set_dhcp_file (String.make 128 '\000') 0 buf;
+ set_dhcp_cookie buf 0x63825363l;
+ let options = Option.Packet.to_bytes options in
+ let options_len = String.length options in
+ Cstruct.set_buffer options 0 buf sizeof_dhcp options_len;
+ let buf = Cstruct.sub buf 0 (sizeof_dhcp+options_len) in
+ Printf.printf "Sending DHCP broadcast\n%!";
+ Udp.output_writebuf t.udp buf
+
+(* Receive a DHCP UDP packet *)
+let input t ~src ~dst ~source_port buf =
+ let ciaddr = ipv4_addr_of_uint32 (get_dhcp_ciaddr buf) in
+ let yiaddr = ipv4_addr_of_uint32 (get_dhcp_yiaddr buf) in
+ let siaddr = ipv4_addr_of_uint32 (get_dhcp_siaddr buf) in
+ let giaddr = ipv4_addr_of_uint32 (get_dhcp_giaddr buf) in
+ let xid = get_dhcp_xid buf in
+ let options = Cstruct.(copy_buffer buf sizeof_dhcp (len buf - sizeof_dhcp)) in
+ let packet = Option.Packet.of_bytes options in
+ (* For debugging, print out the DHCP response *)
+ Printf.printf "DHCP: input ciaddr %s yiaddr %s siaddr %s giaddr %s chaddr %s sname %s file %s\n"
+ (ipv4_addr_to_string ciaddr) (ipv4_addr_to_string yiaddr)
+ (ipv4_addr_to_string siaddr) (ipv4_addr_to_string giaddr)
+ (copy_dhcp_chaddr buf) (copy_dhcp_sname buf) (copy_dhcp_file buf);
+ (* See what state our Netif is in and if this packet is useful *)
+ Option.Packet.(match t.state with
+ | Request_sent xid -> begin
+ (* we are expecting an offer *)
+ match packet.op, xid with
+ |`Offer, offer_xid when offer_xid=xid -> begin
+ printf "DHCP: offer received: %s\n%!" (ipv4_addr_to_string yiaddr);
+ let netmask = find packet
+ (function `Subnet_mask addr -> Some addr |_ -> None) in
+ let gateways = findl packet
+ (function `Router addrs -> Some addrs |_ -> None) in
+ let dns = findl packet
+ (function `DNS_server addrs -> Some addrs |_ -> None) in
+ let lease = 0l in
+ let offer = { ip_addr=yiaddr; netmask; gateways; dns; lease; xid } in
+ (* RFC2131 defines the 'siaddr' as the address of the server which
+ will take part in the next stage of the bootstrap process (eg
+ 'delivery of an operating system executable image'). This
+ may or may not be the address of the DHCP server. However
+ 'a DHCP server always returns its own address in the server
+ identifier option' *)
+ let server_identifier = find packet
+ (function `Server_identifier addr -> Some addr | _ -> None) in
+ let options = { op=`Request; opts=
+ `Requested_ip yiaddr :: (
+ match server_identifier with
+ | Some x -> [ `Server_identifier x ]
+ | None -> []
+ )
+ } in
+ t.state <- Offer_accepted offer;
+ output_broadcast t ~xid ~yiaddr ~siaddr ~options
+ end
+ |_ -> printf "DHCP: offer not for us"; return ()
+ end
+ | Offer_accepted info -> begin
+ (* we are expecting an ACK *)
+ match packet.op, xid with
+ |`Ack, ack_xid when ack_xid = info.xid -> begin
+ let lease =
+ match find packet (function `Lease_time lt -> Some lt |_ -> None) with
+ | None -> 300l (* Just leg it and assume a lease time of 5 minutes *)
+ | Some x -> x in
+ let info = { info with lease=lease } in
+ (* TODO also merge in additional requested options here *)
+ t.state <- Lease_held info;
+ t.new_offer info
+ end
+ |_ -> printf "DHCP: ack not for us\n%!"; return ()
+ end
+ |Shutting_down -> return ()
+ |Lease_held info -> printf "DHCP input: lease already held\n%!"; return ()
+ |Disabled -> printf "DHCP input: disabled\n%!"; return ()
+ )
+
+(* Start a DHCP discovery off on an interface *)
+let start_discovery t =
+ OS.Time.sleep 200000 >>
+ let xid = Random.int32 Int32.max_int in
+ let yiaddr = ipv4_blank in
+ let siaddr = ipv4_blank in
+ let options = { Option.Packet.op=`Discover; opts= [
+ (`Parameter_request [`Subnet_mask; `Router; `DNS_server; `Broadcast]);
+ (`Host_name "miragevm")
+ ] } in
+ Printf.printf "DHCP: start discovery\n%!";
+ t.state <- Request_sent xid;
+ output_broadcast t ~xid ~yiaddr ~siaddr ~options >>
+ return ()
+
+(* DHCP state thred *)
+let rec dhcp_thread t =
+ (* For now, just send out regular discoveries until we have a lease *)
+ match t.state with
+ |Disabled |Request_sent _ ->
+ start_discovery t >>
+ OS.Time.sleep 10000000 >>
+ dhcp_thread t
+ |Shutting_down ->
+ printf "DHCP thread: done\n%!";
+ return ()
+ |_ ->
+ (* TODO: This should be looking at the lease time *)
+ OS.Time.sleep 3600000000 >>
+ dhcp_thread t
+
+(* Create a DHCP thread *)
+let create ip udp =
+ let thread,_ = Lwt.task () in
+ let state = Disabled in
+ (* For now, just block on the first offer
+ and shut down DHCP after. TODO: full protocol *)
+ let first_t, first_u = Lwt.task () in
+ let new_offer info =
+ Printf.printf "DHCP: offer %s %s [%s]\n%!"
+ (ipv4_addr_to_string info.ip_addr)
+ (match info.netmask with |Some ip -> ipv4_addr_to_string ip |None -> "None")
+ (String.concat ", " (List.map ipv4_addr_to_string info.gateways));
+ Ipv4.set_ip ip info.ip_addr >>
+ (match info.netmask with
+ |Some nm -> Ipv4.set_netmask ip nm
+ |None -> return ()) >>
+ Ipv4.set_gateways ip info.gateways >>
+ return (Lwt.wakeup first_u ())
+ in
+ let t = { ip; udp; state; new_offer } in
+ let listen_t = Udp.listen t.udp 68 (input t) in
+ Lwt.on_cancel thread (fun () ->
+ printf "DHCP: shutting down\n%!";
+ t.state <- Shutting_down;
+ Lwt.cancel listen_t
+ );
+ let th = dhcp_thread t <&> listen_t <&> thread in
+ Printf.printf "DHCP: waiting for first offer\n%!";
+ first_t >>
+ return (t, th)
View
39 packages/mirage-net/lib/dhcp/client.mli
@@ -0,0 +1,39 @@
+(*
+ * Copyright (c) 2006-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.
+ *
+ *)
+
+open Nettypes
+
+type offer = {
+ ip_addr : ipv4_addr;
+ netmask : ipv4_addr option;
+ gateways : ipv4_addr list;
+ dns : ipv4_addr list;
+ lease : int32;
+ xid : int32;
+}
+
+type state =
+ Disabled
+ | Request_sent of int32
+ | Offer_accepted of offer
+ | Lease_held of offer
+ | Shutting_down
+
+type t
+
+val input : t -> src:ipv4_addr -> dst:ipv4_addr -> source_port:int -> OS.Io_page.t -> unit Lwt.t
+val create : Ipv4.t -> Udp.t -> (t * unit Lwt.t) Lwt.t
View
2 packages/mirage-net/lib/dhcp/dhcp.mlpack
@@ -0,0 +1,2 @@
+Option
+Client
View
425 packages/mirage-net/lib/dhcp/option.ml
@@ -0,0 +1,425 @@
+(*
+ * Copyright (c) 2006-2010 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.
+ *
+ *)
+
+open Lwt
+open Printf
+open Nettypes
+
+(* This is a hand-crafted DHCP option parser. Did not use MPL
+ here as it doesn't have enough variable length array support
+ yet. At some point, this should be rewritten to use more of the
+ autogen Mpl_stdlib *)
+
+type msg = [ (* Message types, without payloads *)
+|`Pad
+|`Subnet_mask
+|`Time_offset
+|`Router
+|`Broadcast
+|`Time_server
+|`Name_server
+|`DNS_server
+|`Netbios_name_server
+|`Host_name
+|`Domain_name
+|`Requested_ip
+|`Lease_time
+|`Message_type
+|`Server_identifier
+|`Interface_mtu
+|`Parameter_request
+|`Message
+|`Max_size
+|`Client_id
+|`Domain_search (* RFC 3397 *)
+|`End
+|`Unknown of char
+]
+
+type op = [ (* DHCP operations *)
+|`Discover
+|`Offer
+|`Request
+|`Decline
+|`Ack
+|`Nak
+|`Release
+|`Inform
+|`Unknown of char
+]
+
+type t = [ (* Full message payloads *)
+| `Pad
+| `Subnet_mask of ipv4_addr
+| `Time_offset of string
+| `Router of ipv4_addr list
+| `Broadcast of ipv4_addr
+| `Time_server of ipv4_addr list
+| `Name_server of ipv4_addr list
+| `DNS_server of ipv4_addr list
+| `Netbios_name_server of ipv4_addr list
+| `Host_name of string
+| `Domain_name of string
+| `Requested_ip of ipv4_addr
+| `Interface_mtu of int
+| `Lease_time of int32
+| `Message_type of op
+| `Server_identifier of ipv4_addr
+| `Parameter_request of msg list
+| `Message of string
+| `Max_size of int
+| `Client_id of string
+| `Domain_search of string (* not full support yet *)
+| `Unknown of (char * string) (* code * buffer *)
+| `End
+]
+
+let msg_to_string (x:msg) =
+ match x with
+ |`Pad -> "Pad"
+ |`Subnet_mask -> "Subnet mask"
+ |`Broadcast -> "Broadcast"
+ |`Time_offset -> "Time offset"
+ |`Router -> "Router"
+ |`Time_server -> "Time server"
+ |`Name_server -> "Name server"
+ |`DNS_server -> "DNS server"
+ |`Host_name -> "Host name"
+ |`Domain_name -> "Domain name"
+ |`Requested_ip -> "Requested IP"
+ |`Lease_time -> "Lease time"
+ |`Message_type -> "Message type"
+ |`Server_identifier -> "Server identifier"
+ |`Parameter_request -> "Parameter request"
+ |`Message -> "Message"
+ |`Interface_mtu -> "Interface MTU"
+ |`Max_size -> "Max size"
+ |`Client_id -> "Client id"
+ |`Domain_search -> "Domain search"
+ |`Netbios_name_server -> "Netbios name server"
+ |`Unknown c -> sprintf "Unknown(%d)" (Char.code c)
+ |`End -> "End"
+
+let op_to_string (x:op) =
+ match x with
+ |`Discover -> "Discover"
+ |`Offer -> "Offer"
+ |`Request -> "Request"
+ |`Decline -> "Decline"
+ |`Ack -> "Ack"
+ |`Nak -> "Nack"
+ |`Release -> "Release"
+ |`Inform -> "Inform"
+ |`Unknown x -> "Unknown " ^ (string_of_int (Char.code x))
+
+let t_to_string (t:t) =
+ let ip_one s ip = sprintf "%s(%s)" s (ipv4_addr_to_string ip) in
+ let ip_list s ips = sprintf "%s(%s)" s (String.concat "," (List.map ipv4_addr_to_string ips)) in
+ let str s v = sprintf "%s(%s)" s (String.escaped v) in
+ let strs s v = sprintf "%s(%s)" s (String.concat "," v) in
+ let i32 s v = sprintf "%s(%lu)" s v in
+ match t with
+ | `Pad -> "Pad"
+ | `Subnet_mask ip -> ip_one "Subnet mask" ip
+ | `Time_offset x -> "Time offset"
+ | `Broadcast x -> ip_one "Broadcast" x
+ | `Router ips -> ip_list "Routers" ips
+ | `Time_server ips -> ip_list "Time servers" ips
+ | `Name_server ips -> ip_list "Name servers" ips
+ | `DNS_server ips -> ip_list "DNS servers" ips
+ | `Host_name s -> str "Host name" s
+ | `Domain_name s -> str "Domain name" s
+ | `Requested_ip ip -> ip_one "Requested ip" ip
+ | `Lease_time tm -> i32 "Lease time" tm
+ | `Message_type op -> str "Message type" (op_to_string op)
+ | `Server_identifier ip -> ip_one "Server identifer" ip
+ | `Parameter_request ps -> strs "Parameter request" (List.map msg_to_string ps)
+ | `Message s -> str "Message" s
+ | `Max_size sz -> str "Max size" (string_of_int sz)
+ | `Interface_mtu sz -> str "Interface MTU" (string_of_int sz)
+ | `Client_id id -> str "Client id" id
+ | `Domain_search d -> str "Domain search" d
+ | `Netbios_name_server d -> ip_list "NetBIOS name server" d
+ | `Unknown (c,x) -> sprintf "Unknown(%d[%d])" (Char.code c) (String.length x)
+ | `End -> "End"
+
+let ipv4_addr_to_bytes x =
+ let x = ipv4_addr_to_uint32 x in
+ let open Int32 in
+ let r = String.create 4 in
+ r.[0] <- Char.chr (to_int (logand x 0xf_l));
+ r.[1] <- Char.chr (to_int (logand (shift_right_logical x 8) 0xf_l));
+ r.[2] <- Char.chr (to_int (logand (shift_right_logical x 16) 0xf_l));
+ r.[3] <- Char.chr (to_int (logand (shift_right_logical x 24) 0xf_l));
+ r
+
+let ipv4_addr_of_bytes x =
+ let open Int32 in
+ let b n = of_int (Char.code (x.[n])) in
+ let r = add (add (add (shift_left (b 0) 24) (shift_left (b 1) 16)) (shift_left (b 2) 8)) (b 3) in
+ ipv4_addr_of_uint32 r
+
+module Marshal = struct
+ let t_to_code (x:msg) =
+ match x with
+ |`Pad -> 0
+ |`Subnet_mask -> 1
+ |`Time_offset -> 2
+ |`Router -> 3
+ |`Time_server -> 4
+ |`Name_server -> 5
+ |`DNS_server -> 6
+ |`Host_name -> 12
+ |`Domain_name -> 15
+ |`Interface_mtu -> 26
+ |`Broadcast -> 28
+ |`Netbios_name_server -> 44
+ |`Requested_ip -> 50
+ |`Lease_time -> 51
+ |`Message_type -> 53
+ |`Server_identifier -> 54
+ |`Parameter_request -> 55
+ |`Message -> 56
+ |`Max_size -> 57
+ |`Client_id -> 61
+ |`Domain_search -> 119
+ |`End -> 255
+ |`Unknown c -> Char.code c
+
+ let to_byte x = String.make 1 (Char.chr (t_to_code x))
+
+ let uint32_to_bytes s =
+ let x = String.create 4 in
+ let (>!) x y = Int32.logand (Int32.shift_right x y) 255l in
+ x.[0] <- Char.chr (Int32.to_int (s >! 24));
+ x.[1] <- Char.chr (Int32.to_int (s >! 16));
+ x.[2] <- Char.chr (Int32.to_int (s >! 8));
+ x.[3] <- Char.chr (Int32.to_int (s >! 0));
+ x
+
+ let uint16_to_bytes s =
+ let x = String.create 2 in
+ x.[0] <- Char.chr (s land 255);
+ x.[1] <- Char.chr ((s lsl 8) land 255);
+ x
+
+ let size x = String.make 1 (Char.chr x)
+ let ip_list c ips =
+ let x = List.map ipv4_addr_to_bytes ips in
+ to_byte c :: (size (List.length x * 4)) :: x
+ let ip_one c x = to_byte c :: ["\004"; ipv4_addr_to_bytes x]
+ let str c x = to_byte c :: (size (String.length x)) :: [x]
+ let uint32 c x = to_byte c :: [ "\004"; uint32_to_bytes x]
+ let uint16 c x = to_byte c :: [ "\002"; uint16_to_bytes x]
+
+ let to_bytes (x:t) =
+ let bits = match x with
+ |`Pad -> [to_byte `Pad]
+ |`Subnet_mask mask -> ip_one `Subnet_mask mask
+ |`Time_offset off -> assert false (* TODO 2s complement not uint32 *)
+ |`Router ips -> ip_list `Router ips
+ |`Broadcast ip -> ip_one `Broadcast ip
+ |`Time_server ips -> ip_list `Time_server ips
+ |`Name_server ips -> ip_list `Name_server ips
+ |`DNS_server ips -> ip_list `DNS_server ips
+ |`Netbios_name_server ips -> ip_list `Netbios_name_server ips
+ |`Host_name h -> str `Host_name h
+ |`Domain_name n -> str `Domain_name n
+ |`Requested_ip ip -> ip_one `Requested_ip ip
+ |`Lease_time t -> uint32 `Lease_time t
+ |`Message x -> str `Message x
+ |`Max_size s -> uint16 `Max_size s
+ |`Interface_mtu s -> uint16 `Interface_mtu s
+ |`Message_type mtype ->
+ let mcode = function
+ |`Discover -> "\001"
+ |`Offer -> "\002"
+ |`Request -> "\003"
+ |`Decline -> "\004"
+ |`Ack -> "\005"
+ |`Nak -> "\006"
+ |`Release -> "\007"
+ |`Inform -> "\008"
+ |`Unknown x -> String.make 1 x in
+ to_byte `Message_type :: "\001" :: [mcode mtype]
+ |`Server_identifier id -> ip_one `Server_identifier id
+ |`Parameter_request ps ->
+ to_byte `Parameter_request :: (size (List.length ps)) ::
+ List.map to_byte ps
+ |`Client_id s ->
+ let s' = "\000" ^ s in (* only support domain name ids *)
+ str `Client_id s'
+ |`Domain_search s ->
+ assert false (* not supported yet, requires annoying DNS compression *)
+ |`End -> [to_byte `End]
+ |`Unknown (c,x) -> [ (String.make 1 c); x ]
+ in String.concat "" bits
+
+ let options mtype xs =
+ let buf = String.make 312 '\000' in
+ let p = String.concat "" (List.map to_bytes (`Message_type mtype :: xs @ [`End])) in
+ (* DHCP packets have minimum length, hence the blit into buf *)
+ String.blit p 0 buf 0 (String.length p);
+ buf
+end
+
+module Unmarshal = struct
+
+ exception Error of string
+
+ let msg_of_code x : msg =
+ match x with
+ |'\000' -> `Pad
+ |'\001' -> `Subnet_mask
+ |'\002' -> `Time_offset
+ |'\003' -> `Router
+ |'\004' -> `Time_server
+ |'\005' -> `Name_server
+ |'\006' -> `DNS_server
+ |'\012' -> `Host_name
+ |'\015' -> `Domain_name
+ |'\026' -> `Interface_mtu
+ |'\028' -> `Broadcast
+ |'\044' -> `Netbios_name_server
+ |'\050' -> `Requested_ip
+ |'\051' -> `Lease_time
+ |'\053' -> `Message_type
+ |'\054' -> `Server_identifier
+ |'\055' -> `Parameter_request
+ |'\056' -> `Message
+ |'\057' -> `Max_size
+ |'\061' -> `Client_id
+ |'\119' -> `Domain_search
+ |'\255' -> `End
+ |x -> `Unknown x
+
+ let of_bytes buf : t list =
+ let pos = ref 0 in
+ let getc () = (* Get one character *)
+ let r = String.get buf !pos in
+ pos := !pos + 1;
+ r in
+ let getint () = (* Get one integer *)
+ Char.code (getc ()) in
+ let slice len = (* Get a substring *)
+ let r = String.sub buf !pos len in
+ pos := !pos + len;
+ r in
+ let check c = (* Check that a char is the provided value *)
+ let r = getc () in
+ if r != c then raise (Error (sprintf "check failed at %d != %d" !pos (Char.code c))) in
+ let get_addr fn = (* Get one address *)
+ check '\004';
+ fn (slice 4) in
+ let get_addrs fn = (* Repeat fn n times and return the list *)
+ let len = getint () / 4 in
+ let res = ref [] in
+ for i = 1 to len do
+ res := (fn (slice 4)) :: !res
+ done;
+ List.rev !res in
+ let uint32_of_bytes x =
+ let fn p = Int32.shift_left (Int32.of_int (Char.code x.[p])) ((3-p)*8) in
+ let (++) = Int32.add in
+ (fn 0) ++ (fn 1) ++ (fn 2) ++ (fn 3) in
+ let rec fn acc =
+ let cont (r:t) = fn (r :: acc) in
+ let code = msg_of_code (getc ()) in
+ match code with
+ |`Pad -> fn acc
+ |`Subnet_mask -> cont (`Subnet_mask (get_addr ipv4_addr_of_bytes))
+ |`Time_offset -> cont (`Time_offset (get_addr (fun x -> x)))
+ |`Router -> cont (`Router (get_addrs ipv4_addr_of_bytes))
+ |`Broadcast -> cont (`Broadcast (get_addr ipv4_addr_of_bytes))
+ |`Time_server -> cont (`Time_server (get_addrs ipv4_addr_of_bytes))
+ |`Name_server -> cont (`Name_server (get_addrs ipv4_addr_of_bytes))
+ |`DNS_server -> cont (`DNS_server (get_addrs ipv4_addr_of_bytes))
+ |`Host_name -> cont (`Host_name (slice (getint ())))
+ |`Domain_name -> cont (`Domain_name (slice (getint ())))
+ |`Requested_ip -> cont (`Requested_ip (get_addr ipv4_addr_of_bytes))
+ |`Server_identifier -> cont (`Server_identifier (get_addr ipv4_addr_of_bytes))
+ |`Lease_time -> cont (`Lease_time (get_addr uint32_of_bytes))
+ |`Domain_search -> cont (`Domain_search (slice (getint())))
+ |`Netbios_name_server -> cont (`Netbios_name_server (get_addrs ipv4_addr_of_bytes))
+ |`Message -> cont (`Message (slice (getint ())))
+ |`Message_type ->
+ check '\001';
+ let mcode = match (getc ()) with
+ |'\001' -> `Discover
+ |'\002' -> `Offer
+ |'\003' -> `Request
+ |'\004' -> `Decline
+ |'\005' -> `Ack
+ |'\006' -> `Nak
+ |'\007' -> `Release
+ |'\008' -> `Inform
+ |x -> `Unknown x in
+ cont (`Message_type mcode)
+ |`Parameter_request ->
+ let len = getint () in
+ let params = ref [] in
+ for i = 1 to len do
+ params := (msg_of_code (getc ())) :: !params
+ done;
+ cont (`Parameter_request (List.rev !params))
+ |`Max_size ->
+ let l1 = getint () lsl 8 in
+ cont (`Max_size (getint () + l1))
+ |`Interface_mtu ->
+ let l1 = getint () lsl 8 in
+ cont (`Interface_mtu (getint () + l1))
+ |`Client_id ->
+ let len = getint () in
+ let _ = getint () in
+ cont (`Client_id (slice len))
+ |`End -> acc
+ |`Unknown c -> cont (`Unknown (c, (slice (getint ()))))
+ in
+ fn []
+end
+
+module Packet = struct
+ type p = {
+ op: op;
+ opts: t list;
+ }
+
+ let of_bytes buf =
+ let opts = Unmarshal.of_bytes buf in
+ let mtype, rest = List.partition (function `Message_type _ -> true |_ -> false) opts in
+ let op = match mtype with [ `Message_type m ] -> m |_ -> raise (Unmarshal.Error "no mtype") in
+ { op=op; opts=rest }
+
+ let to_bytes p =
+ Marshal.options p.op p.opts
+
+ let prettyprint t =
+ sprintf "%s : %s" (op_to_string t.op) (String.concat ", " (List.map t_to_string t.opts))
+
+ (* Find an option in a packet *)
+ let find p fn =
+ List.fold_left (fun a b ->
+ match fn b with
+ |Some x -> Some x
+ |None -> a) None p.opts
+
+ (* Find an option list, and return empty list if opt doesnt exist *)
+ let findl p fn =
+ match find p fn with
+ |Some l -> l
+ |None -> []
+end
View
110 packages/mirage-net/lib/dhcp/option.mli
@@ -0,0 +1,110 @@
+(*
+ * Copyright (c) 2006-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.
+ *
+ *)
+
+type msg =
+ [ `Broadcast
+ | `Client_id
+ | `DNS_server
+ | `Domain_name
+ | `Domain_search
+ | `End
+ | `Host_name
+ | `Interface_mtu
+ | `Lease_time
+ | `Max_size
+ | `Message
+ | `Message_type
+ | `Name_server
+ | `Netbios_name_server
+ | `Pad
+ | `Parameter_request
+ | `Requested_ip
+ | `Router
+ | `Server_identifier
+ | `Subnet_mask
+ | `Time_offset
+ | `Time_server
+ | `Unknown of char ]
+type op =
+ [ `Ack
+ | `Decline
+ | `Discover
+ | `Inform
+ | `Nak
+ | `Offer
+ | `Release
+ | `Request
+ | `Unknown of char ]
+type t =
+ [ `Broadcast of Nettypes.ipv4_addr
+ | `Client_id of string
+ | `DNS_server of Nettypes.ipv4_addr list
+ | `Domain_name of string
+ | `Domain_search of string
+ | `End
+ | `Host_name of string
+ | `Interface_mtu of int
+ | `Lease_time of int32
+ | `Max_size of int
+ | `Message of string
+ | `Message_type of op
+ | `Name_server of Nettypes.ipv4_addr list
+ | `Netbios_name_server of Nettypes.ipv4_addr list
+ | `Pad
+ | `Parameter_request of msg list
+ | `Requested_ip of Nettypes.ipv4_addr
+ | `Router of Nettypes.ipv4_addr list
+ | `Server_identifier of Nettypes.ipv4_addr
+ | `Subnet_mask of Nettypes.ipv4_addr
+ | `Time_offset of string
+ | `Time_server of Nettypes.ipv4_addr list
+ | `Unknown of char * string ]
+val msg_to_string : msg -> string
+val op_to_string : op -> string
+val t_to_string : t -> string
+val ipv4_addr_to_bytes : Nettypes.ipv4_addr -> string
+val ipv4_addr_of_bytes : string -> Nettypes.ipv4_addr
+module Marshal :
+ sig
+ val t_to_code : msg -> int
+ val to_byte : msg -> string
+ val uint32_to_bytes : int32 -> string
+ val uint16_to_bytes : int -> string
+ val size : int -> string
+ val ip_list : msg -> Nettypes.ipv4_addr list -> string list
+ val ip_one : msg -> Nettypes.ipv4_addr -> string list
+ val str : msg -> string -> string list
+ val uint32 : msg -> int32 -> string list
+ val uint16 : msg -> int -> string list
+ val to_bytes : t -> string
+ val options : op -> t list -> string
+ end
+module Unmarshal :
+ sig
+ exception Error of string
+ val msg_of_code : char -> msg
+ val of_bytes : string -> t list
+ end
+module Packet :
+ sig
+ type p = { op : op; opts : t list; }
+ val of_bytes : string -> p
+ val to_bytes : p -> string
+ val prettyprint : p -> string
+ val find : p -> (t -> 'a option) -> 'a option
+ val findl : p -> (t -> 'a list option) -> 'a list
+ end
View
87 packages/mirage-net/lib/ethif.ml
@@ -0,0 +1,87 @@
+(*
+ * Copyright (c) 2010-2011 Anil Madhavapeddy <anil@recoil.org>
+ * Copyright (c) 2011 Richard Mortier <richard.mortier@nottingham.ac.uk>
+ *
+ * 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 Lwt
+open Nettypes
+open Printf
+
+type t = {
+ ethif: OS.Netif.t;
+ mac: ethernet_mac;
+ arp: Arp.t;
+ mutable ipv4: (OS.Io_page.t -> unit Lwt.t);
+}
+
+cstruct ethernet {
+ uint8_t dst[6];
+ uint8_t src[6];
+ uint16_t ethertype
+} as big_endian
+
+(* Handle a single input frame *)
+let input t frame =
+ match get_ethernet_ethertype frame with
+ |0x0806 -> (* ARP *)
+ Arp.input t.arp frame
+ |0x0800 -> (* IPv4 *)
+ let payload = Cstruct.shift frame sizeof_ethernet in
+ t.ipv4 payload
+ |0x86dd -> (* IPv6 *)
+ return (printf "Ethif: discarding ipv6\n%!")
+ |etype ->
+ return (printf "Ethif: unknown frame %x\n%!" etype)
+
+(* Loop and listen for frames *)
+let rec listen t =
+ OS.Netif.listen t.ethif (input t)
+
+(* Return an Ethernet buffer. The caller is responsible for creating a
+ * sub-view of the payload. *)
+let get_etherbuf t =
+ OS.Netif.get_writebuf t.ethif
+
+let write t buf =
+ OS.Netif.write t.ethif buf
+
+let writev t bufs =
+ OS.Netif.writev t.ethif bufs
+
+let create ethif =
+ let ipv4 = (fun _ -> return ()) in
+ let mac = ethernet_mac_of_bytes (OS.Netif.mac ethif) in
+ let arp =
+ let get_mac () = mac in
+ let get_etherbuf () = OS.Netif.get_writebuf ethif in
+ let output buf = OS.Netif.write ethif buf in
+ Arp.create ~output ~get_mac ~get_etherbuf in
+ let t = { ethif; ipv4; mac; arp } in
+ let listen = listen t in
+ (t, listen)
+
+let add_ip t = Arp.add_ip t.arp
+let remove_ip t = Arp.remove_ip t.arp
+let query_arp t = Arp.query t.arp
+
+let attach t = function
+ |`IPv4 fn -> t.ipv4 <- fn
+
+let detach t = function
+ |`IPv4 -> t.ipv4 <- (fun _ -> return ())
+
+let mac t = t.mac
+let get_ethif t =
+ t.ethif
View
42 packages/mirage-net/lib/ethif.mli
@@ -0,0 +1,42 @@
+(*
+ * Copyright (c) 2010-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.
+ *
+ *)
+
+open Nettypes
+
+type t
+
+val input : t -> OS.Io_page.t -> unit Lwt.t
+val listen : t -> unit Lwt.t
+val write : t -> OS.Io_page.t -> unit Lwt.t
+val writev : t -> OS.Io_page.t list -> unit Lwt.t
+val create : OS.Netif.t -> t * unit Lwt.t
+
+val add_ip : t -> Nettypes.ipv4_addr -> unit Lwt.t
+val remove_ip : t -> Nettypes.ipv4_addr -> unit Lwt.t
+val query_arp : t -> Nettypes.ipv4_addr -> Nettypes.ethernet_mac Lwt.t
+
+val get_etherbuf : t -> OS.Io_page.t Lwt.t
+
+val attach : t -> [< `IPv4 of OS.Io_page.t -> unit Lwt.t ] -> unit
+val detach : t -> [< `IPv4 ] -> unit
+val mac : t -> Nettypes.ethernet_mac
+val get_ethif : t -> OS.Netif.t
+
+val sizeof_ethernet : int
+val set_ethernet_dst : string -> int -> OS.Io_page.t -> unit
+val set_ethernet_src : string -> int -> OS.Io_page.t -> unit
+val set_ethernet_ethertype : OS.Io_page.t -> int -> unit
View
127 packages/mirage-net/lib/flow.ml
@@ -0,0 +1,127 @@
+(*
+ * 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.
+ *)
+
+open Lwt
+open Nettypes
+
+type ipv4_src = ipv4_addr option * int (* optional IP address * port *)
+type ipv4_dst = ipv4_addr * int (* specific IP address * port *)
+
+module TCPv4 = struct
+
+ type t = Tcp.Pcb.pcb
+ type mgr = Manager.t
+ type src = ipv4_src
+ type dst = ipv4_dst
+
+ let read t =
+ Tcp.Pcb.read t
+
+ let rec write t view =
+ let vlen = Cstruct.len view in
+ match Tcp.Pcb.write_available t with
+ |len when len < vlen -> (* block for window to open *)
+ Tcp.Pcb.write_wait_for t vlen >>
+ write t view
+ |len -> (* full write *)
+ Tcp.Pcb.write t view
+
+ let writev t views =
+ Tcp.Pcb.writev t views
+
+ let close t =
+ Tcp.Pcb.close t
+
+ let listen mgr src fn =
+ let addr, port = src in
+ let tcps = Manager.tcpv4_of_addr mgr addr in
+ lwt str_lst = Lwt_list.map_s (fun tcp -> return (Tcp.Pcb.listen tcp port)) tcps in
+ let rec accept (st, l) =
+ lwt c = Lwt_stream.get st in
+ match c with
+ | None -> begin
+ return ()
+ end
+ | Some (fl, th) -> begin
+ let _ = fn (Tcp.Pcb.get_dest fl) fl in
+ accept (st, l)
+ end
+ in
+ let _ = Lwt_list.iter_p accept str_lst in
+ let th,_ = Lwt.task () in
+ let cancelone (_, l) = Tcp.Pcb.closelistener l in
+ Lwt.on_cancel th (fun () -> List.iter cancelone str_lst);
+ th
+
+ let connect mgr ?src dst fn =
+ fail (Failure "Not_implemented")
+
+end
+
+(* Shared mem communication across VMs, not yet implemented *)
+module Shmem = struct
+ type t = unit
+ type mgr = Manager.t
+ type src = int
+ type dst = int
+
+ let read t = fail (Failure "read")
+ let write t view = fail (Failure "write")
+ let writev t views = fail (Failure "writev")
+ let close t = fail (Failure "close")
+
+ let listen mgr src fn = fail (Failure "listen")
+ let connect mgr ?src dst fn = fail (Failure "connect")
+
+end
+
+type t =
+ | TCPv4 of TCPv4.t
+ | Shmem of Shmem.t
+
+type mgr = Manager.t
+
+let read = function
+ | TCPv4 t -> TCPv4.read t
+ | Shmem t -> Shmem.read t
+
+let write = function
+ | TCPv4 t -> TCPv4.write t
+ | Shmem t -> Shmem.write t
+
+let writev = function
+ | TCPv4 t -> TCPv4.writev t
+ | Shmem t -> Shmem.writev t
+
+let close = function
+ | TCPv4 t -> TCPv4.close t
+ | Shmem t -> Shmem.close t
+
+let connect mgr = function
+ |`TCPv4 (src, dst, fn) ->
+ TCPv4.connect mgr ?src dst (fun t -> fn (TCPv4 t))
+ |`Shmem (src, dst, fn) ->
+ Shmem.connect mgr ?src dst (fun t -> fn (Shmem t))
+ |_ -> fail (Failure "unknown protocol")
+
+let listen mgr = function
+ |`TCPv4 (src, fn) ->
+ TCPv4.listen mgr src (fun dst t -> fn dst (TCPv4 t))
+ |`Shmem (src, fn) ->
+ Shmem.listen mgr src (fun dst t -> fn dst (Shmem t))
+ |_ -> fail (Failure "unknown protocol")
+
+
View
49 packages/mirage-net/lib/flow.mli
@@ -0,0 +1,49 @@
+(*
+ * 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.
+ *)
+
+open Nettypes
+
+type ipv4_src = ipv4_addr option * int
+type ipv4_dst = ipv4_addr * int
+
+module TCPv4 : FLOW with
+ type mgr = Manager.t
+ and type src = ipv4_src
+ and type dst = ipv4_dst
+
+module Shmem : FLOW with
+ type mgr = Manager.t
+ and type src = peer_uid
+ and type dst = peer_uid
+
+type t
+val read: t -> OS.Io_page.t option Lwt.t
+val write: t -> OS.Io_page.t -> unit Lwt.t
+val writev: t -> OS.Io_page.t list -> unit Lwt.t
+val close: t -> unit Lwt.t
+
+val connect :
+ Manager.t -> [>
+ | `Shmem of peer_uid option * peer_uid * (t -> 'a Lwt.t)
+ | `TCPv4 of ipv4_src option * ipv4_dst * (t -> 'a Lwt.t)
+ ] -> 'a Lwt.t
+
+val listen :
+ Manager.t -> [>
+ | `Shmem of peer_uid * (peer_uid -> t -> unit Lwt.t)
+ | `TCPv4 of ipv4_src * (ipv4_dst -> t -> unit Lwt.t)
+ ] -> unit Lwt.t
+
View
59 packages/mirage-net/lib/icmp.ml
@@ -0,0 +1,59 @@
+(*
+ * Copyright (c) 2010-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.
+ *)
+
+open Lwt
+open Printf
+open Nettypes
+
+cstruct icmpv4 {
+ uint8_t ty;
+ uint8_t code;
+ uint16_t csum;
+ uint16_t id;
+ uint16_t seq
+} as big_endian
+
+type t = {
+ ip: Ipv4.t;
+}
+
+let input t src hdr buf =
+ match get_icmpv4_ty buf with
+ |0 -> (* echo reply *)
+ return (printf "ICMP: discarding echo reply\n%!")
+ |8 -> (* echo request *)
+ let csum =
+ let orig_csum = get_icmpv4_csum buf in
+ let shift = if orig_csum > 0xffff -0x0800 then 0x0801 else 0x0800 in
+ (orig_csum + shift) land 0xffff in
+ lwt header = Ipv4.get_writebuf ~proto:`ICMP ~dest_ip:src t.ip in
+ set_icmpv4_ty buf 0;
+ set_icmpv4_csum buf csum;
+ let header = Cstruct.sub header 0 0 in
+ Ipv4.writev t.ip ~header [buf]
+ |ty ->
+ printf "ICMP unknown ty %d\n" ty;
+ return ()
+
+let create ip =
+ let t = { ip } in
+ Ipv4.attach ip (`ICMP (input t));
+ let th,_ = Lwt.task () in
+ Lwt.on_cancel th (fun () ->
+ printf "ICMP: shutting down\n%!";
+ Ipv4.detach ip `ICMP;
+ );
+ t, th
View
21 packages/mirage-net/lib/icmp.mli
@@ -0,0 +1,21 @@
+(*
+ * Copyright (c) 2010-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.
+ *)
+
+open Nettypes
+
+type t
+
+val create : Ipv4.t -> t * unit Lwt.t
View
4 packages/mirage-net/lib/ip/iP.mlpack
@@ -0,0 +1,4 @@
+Netif
+Arp
+Icmp
+Ipv4
View
189 packages/mirage-net/lib/ipv4.ml
@@ -0,0 +1,189 @@
+(*
+ * Copyright (c) 2010-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.
+ *)
+
+open Lwt
+open Printf
+open Nettypes
+
+cstruct ipv4 {
+ uint8_t hlen_version;
+ uint8_t tos;
+ uint16_t len;
+ uint16_t id;
+ uint16_t off;
+ uint8_t ttl;
+ uint8_t proto;
+ uint16_t csum;
+ uint32_t src;
+ uint32_t dst
+} as big_endian
+
+type t = {
+ ethif: Ethif.t;
+ mutable ip: ipv4_addr;
+ mutable netmask: ipv4_addr;
+ mutable gateways: ipv4_addr list;
+ mutable icmp: ipv4_addr -> OS.Io_page.t -> OS.Io_page.t -> unit Lwt.t;
+ mutable udp: src:ipv4_addr -> dst:ipv4_addr -> OS.Io_page.t -> unit Lwt.t;
+ mutable tcp: src:ipv4_addr -> dst:ipv4_addr -> OS.Io_page.t -> unit Lwt.t;
+}
+
+module Routing = struct
+
+ type classify =
+ |Broadcast
+ |Gateway
+ |Local
+
+ exception No_route_to_destination_address of ipv4_addr
+
+ let is_local t ip =
+ let ipand a b = Int32.logand (ipv4_addr_to_uint32 a) (ipv4_addr_to_uint32 b) in
+ (ipand t.ip t.netmask) = (ipand ip t.netmask)
+
+ let destination_mac t =
+ function
+ |ip when ip = ipv4_broadcast || ip = ipv4_blank -> (* Broadcast *)
+ return ethernet_mac_broadcast
+ |ip when is_local t ip -> (* Local *)
+ Ethif.query_arp t.ethif ip
+ |ip -> begin (* Gateway *)
+ match t.gateways with
+ |hd::_ -> Ethif.query_arp t.ethif hd
+ |[] ->
+ printf "IP.output: no route to %s\n%!" (ipv4_addr_to_string ip);
+ fail (No_route_to_destination_address ip)
+ end
+end
+
+(* Return a buffer, and offset within the buffer that the IPv4
+ * payload begins. The caller is responsible for creating a sub-view
+ * for the IPv4 payload to be filled in *)
+let get_writebuf ~proto ~dest_ip t =
+ lwt buf = Ethif.get_etherbuf t.ethif in
+ (* Something of a layer violation here, but ARP is awkward *)
+ lwt dmac = Routing.destination_mac t dest_ip >|= ethernet_mac_to_bytes in
+ let smac = ethernet_mac_to_bytes (Ethif.mac t.ethif) in
+ Ethif.set_ethernet_dst dmac 0 buf;
+ Ethif.set_ethernet_src smac 0 buf;
+ Ethif.set_ethernet_ethertype buf 0x0800;
+ let ipv4_buf = Cstruct.shift buf Ethif.sizeof_ethernet in
+ (* Write the constant IPv4 header fields *)
+ set_ipv4_hlen_version ipv4_buf ((4 lsl 4) + (5)); (* TODO options *)
+ set_ipv4_tos ipv4_buf 0;
+ set_ipv4_off ipv4_buf 0; (* TODO fragmentation *)
+ set_ipv4_ttl ipv4_buf 38; (* TODO *)
+ let proto = match proto with |`ICMP -> 1 |`TCP -> 6 |`UDP -> 17 in
+ set_ipv4_proto ipv4_buf proto;
+ set_ipv4_src ipv4_buf (ipv4_addr_to_uint32 t.ip);
+ set_ipv4_dst ipv4_buf (ipv4_addr_to_uint32 dest_ip);
+ let payload = Cstruct.shift ipv4_buf sizeof_ipv4 in
+ return payload
+
+let adjust_output_header ~tlen buf =
+ (* Shift the packet to expose the ipv4 header *)
+ let _ = Cstruct.shift_left buf sizeof_ipv4 in
+ (* Set the mutable values in the ipv4 header *)
+ set_ipv4_len buf tlen;
+ set_ipv4_id buf (Random.int 65535); (* TODO *)
+ set_ipv4_csum buf 0;
+ let checksum = Checksum.ones_complement buf sizeof_ipv4 in
+ set_ipv4_csum buf checksum;
+ (* Final shift to expose the Ethernet headers *)
+ let _ = Cstruct.shift_left buf Ethif.sizeof_ethernet in
+ ()
+
+(* This buffer will be the full frame of headers, as passed by
+ * get_writebuf, but truncated from the right to indicate the end
+ * of the packet data.
+ *)
+let write t buf =
+ (* At this point, buf points to the ipv4 payload *)
+ let ihl = 5 in (* TODO options *)
+ let tlen = (ihl * 4) + (Cstruct.len buf) in
+ adjust_output_header ~tlen buf;
+ Ethif.write t.ethif buf
+
+let writev t ~header bufs =
+ (* The header needs to be shifted back *)
+ let ihl = 5 in (* TODO options *)
+ let tlen = (ihl * 4) + (Cstruct.len header) + (Cstruct.lenv bufs) in
+ adjust_output_header ~tlen header;
+ Ethif.writev t.ethif (header::bufs)
+
+let input t buf =
+ (* buf pointers to to start of IPv4 header here *)
+ let ihl = (get_ipv4_hlen_version buf land 0xf) * 4 in
+ let src = ipv4_addr_of_uint32 (get_ipv4_src buf) in
+ let dst = ipv4_addr_of_uint32 (get_ipv4_dst buf) in
+ let payload_len = get_ipv4_len buf - ihl in
+ (* XXX this will raise exception for 0-length payload *)
+ let hdr = Cstruct.sub buf 0 ihl in
+ let data = Cstruct.sub buf ihl payload_len in
+ match get_ipv4_proto buf with
+ |1 -> (* ICMP *)
+ t.icmp src hdr data
+ |6 -> (* TCP *)
+ t.tcp ~src ~dst data
+ |17 -> (* UDP *)
+ t.udp ~src ~dst data
+ |proto -> return (printf "IPv4: dropping proto %d\n%!" proto)
+
+let default_icmp = fun _ _ _ -> return ()
+let default_udp = fun ~src ~dst _ -> return ()
+let default_tcp = fun ~src ~dst _ -> return ()
+
+let create ethif =
+ let ip = ipv4_blank in
+ let netmask = ipv4_blank in
+ let gateways = [] in
+ let icmp = default_icmp in
+ let udp = default_udp in
+ let tcp = default_tcp in
+ let t = { ethif; ip; netmask; gateways; icmp; udp; tcp } in
+ Ethif.attach ethif (`IPv4 (input t));
+ let th,_ = Lwt.task () in
+ Lwt.on_cancel th (fun () ->
+ printf "IPv4: shutting down\n%!";
+ Ethif.detach ethif `IPv4);
+ t, th
+
+let attach t = function
+ |`ICMP x -> t.icmp <- x
+ |`UDP x -> t.udp <- x
+ |`TCP x -> t.tcp <- x
+
+let detach t = function
+ |`ICMP -> t.icmp <- default_icmp
+ |`UDP -> t.udp <- default_udp
+ |`TCP -> t.tcp <- default_tcp
+
+let set_ip t ip =
+ t.ip <- ip;
+ (* Inform ARP layer of new IP *)
+ Ethif.add_ip t.ethif ip
+
+let get_ip t = t.ip
+
+let set_netmask t netmask =
+ t.netmask <- netmask;
+ return ()
+
+let set_gateways t gateways =
+ t.gateways <- gateways;
+ return ()
+
+let mac t = Ethif.mac t.ethif
View
37 packages/mirage-net/lib/ipv4.mli
@@ -0,0 +1,37 @@
+(*
+ * Copyright (c) 2010 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.