diff --git a/.travis.yml b/.travis.yml index a20fb12c3..53b2ee350 100644 --- a/.travis.yml +++ b/.travis.yml @@ -3,7 +3,7 @@ script: bash -ex .travis-ci.sh sudo: required env: global: - - EXTRA_REMOTES="https://github.com/mirage/mirage-dev.git" + - EXTRA_REMOTES="https://github.com/yomimono/mirage-dev.git#normalize-ipv4" matrix: - OCAML_VERSION=4.02 PACKAGE=tcpip MIRAGE_MODE=unix - UPDATE_GCC_BINUTILS=1 OCAML_VERSION=4.02 PACKAGE=tcpip MIRAGE_MODE=xen diff --git a/_oasis b/_oasis index acd729106..110d44438 100644 --- a/_oasis +++ b/_oasis @@ -55,7 +55,8 @@ Library ipv4 Path: lib/ipv4 Findlibparent: tcpip Findlibname: ipv4 - Modules: Ipv4, Ipv4_wire, Ipv4_packet + Modules: Static_ipv4, Ipv4_wire, Ipv4_packet + InternalModules: Ipv4_common, Routing BuildDepends: logs,io-page,mirage-types,ipaddr,cstruct.ppx,lwt,result,rresult, tcpip,tcpip.ethif @@ -100,23 +101,13 @@ Library tcp io-page, tcpip, duration, randomconv -Library dhcpv4 - CompiledObject: best - Path: lib/dhcp - Findlibparent: tcpip - Findlibname: dhcpv4 - Modules: Dhcpv4_option,Dhcp_clientv4 - BuildDepends: logs,io-page,mirage-types,ipaddr,cstruct,cstruct.ppx,lwt, - tcpip.udp, duration, randomconv - Library "tcpip-stack-direct" CompiledObject: best Path: lib Findlibparent: tcpip Findlibname: stack-direct Modules: Tcpip_stack_direct - BuildDepends: logs,mirage-types,ipaddr,lwt, - tcpip.dhcpv4, result + BuildDepends: logs,mirage-types,ipaddr,lwt,result Library "icmpv4-socket" CompiledObject: best diff --git a/_tags b/_tags index 20f406b5c..36ba015af 100644 --- a/_tags +++ b/_tags @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 932c2d4a28d84c22430fe4df82d8b59a) +# DO NOT EDIT (digest: 61581dffdce93c14e7b62030da4e6737) # Ignore VCS directories, you can use the same kind of rule outside # OASIS_START/STOP if you want to exclude directories that contains # useless stuff for the build process @@ -19,6 +19,7 @@ true: annot, bin_annot : oasis_library_tcpip_ccopt "lib/checksum_stubs.c": oasis_library_tcpip_ccopt : use_libtcpip_stubs +: pkg_cstruct "lib/checksum_stubs.c": pkg_cstruct "lib/checksum_stubs.c": pkg_ipaddr "lib/checksum_stubs.c": pkg_mirage-types @@ -132,39 +133,13 @@ true: annot, bin_annot : pkg_result : pkg_rresult : use_tcpip -# Library dhcpv4 -"lib/dhcp/dhcpv4.cmxs": use_dhcpv4 -: pkg_cstruct -: pkg_cstruct.ppx -: pkg_duration -: pkg_io-page -: pkg_ipaddr -: pkg_logs -: pkg_lwt -: pkg_mirage-profile -: pkg_mirage-types -: pkg_randomconv -: pkg_result -: pkg_rresult -: use_tcpip -: use_udp # Library tcpip-stack-direct "lib/tcpip-stack-direct.cmxs": use_tcpip-stack-direct -: pkg_cstruct -: pkg_cstruct.ppx -: pkg_duration -: pkg_io-page : pkg_ipaddr : pkg_logs : pkg_lwt -: pkg_mirage-profile : pkg_mirage-types -: pkg_randomconv : pkg_result -: pkg_rresult -: use_dhcpv4 -: use_tcpip -: use_udp # Library icmpv4-socket "unix/icmpv4-socket.cmxs": use_icmpv4-socket : pkg_cstruct @@ -220,7 +195,6 @@ true: annot, bin_annot : pkg_result : pkg_rresult : use_arpv4 -: use_dhcpv4 : use_ethif : use_icmpv4 : use_ipv4 @@ -257,7 +231,6 @@ true: annot, bin_annot : pkg_result : pkg_rresult : use_arpv4 -: use_dhcpv4 : use_ethif : use_icmpv4 : use_ipv4 diff --git a/lib/META b/lib/META index 7c6e0cc03..ba07309f3 100644 --- a/lib/META +++ b/lib/META @@ -1,5 +1,5 @@ # OASIS_START -# DO NOT EDIT (digest: 0289584629c88bb3ad579364942336e4) +# DO NOT EDIT (digest: 19248bdbc381f553626b53890e652d93) version = "2.8.0" description = "Implementations for network-related module types from MirageOS." @@ -112,7 +112,7 @@ package "stack-direct" ( version = "2.8.0" description = "Implementations for network-related module types from MirageOS." - requires = "logs mirage-types ipaddr lwt tcpip.dhcpv4 result" + requires = "logs mirage-types ipaddr lwt result" archive(byte) = "tcpip-stack-direct.cma" archive(byte, plugin) = "tcpip-stack-direct.cma" archive(native) = "tcpip-stack-direct.cmxa" @@ -184,19 +184,6 @@ package "ethif" ( exists_if = "ethif.cma" ) -package "dhcpv4" ( - version = "2.8.0" - description = - "Implementations for network-related module types from MirageOS." - requires = - "logs io-page mirage-types ipaddr cstruct cstruct.ppx lwt tcpip.udp duration randomconv" - archive(byte) = "dhcpv4.cma" - archive(byte, plugin) = "dhcpv4.cma" - archive(native) = "dhcpv4.cmxa" - archive(native, plugin) = "dhcpv4.cmxs" - exists_if = "dhcpv4.cma" -) - package "arpv4" ( version = "2.8.0" description = diff --git a/lib/dhcp/dhcp.mlpack b/lib/dhcp/dhcp.mlpack deleted file mode 100644 index 5a45f4579..000000000 --- a/lib/dhcp/dhcp.mlpack +++ /dev/null @@ -1,2 +0,0 @@ -Option -Client diff --git a/lib/dhcp/dhcp_clientv4.ml b/lib/dhcp/dhcp_clientv4.ml deleted file mode 100644 index a57f30fe6..000000000 --- a/lib/dhcp/dhcp_clientv4.ml +++ /dev/null @@ -1,253 +0,0 @@ -(* - * Copyright (c) 2006-2011 Anil Madhavapeddy - * - * 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 src = Logs.Src.create "dhcp-clientv4" ~doc:"Mirage TCPIP's IPv4 DHCP client" -module Log = (val Logs.src_log src : Logs.LOG) - -open Lwt.Infix - -module Make - (Time : V1_LWT.TIME) - (Random : V1_LWT.RANDOM) - (Udp : V1_LWT.UDPV4) = struct - - type offer = { - ip_addr: Ipaddr.V4.t; - netmask: Ipaddr.V4.t option; - gateways: Ipaddr.V4.t list; - dns: Ipaddr.V4.t 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; - mac: Macaddr.t; - mutable state: state; - new_offer: offer -> unit Lwt.t; - } - - [%%cstruct - type dhcp = { - op: uint8_t; - htype: uint8_t; - hlen: uint8_t; - hops: uint8_t; - xid: uint32_t; - secs: uint16_t; - flags: uint16_t; - ciaddr: uint32_t; - yiaddr: uint32_t; - siaddr: uint32_t; - giaddr: uint32_t; - chaddr: uint8_t [@len 16]; - sname: uint8_t [@len 64]; - file: uint8_t [@len 128]; - cookie: uint32_t; - } [@@big_endian] - ] - [%%cenum - type mode = - | BootRequest [@id 1] - | BootReply - [@@uint8_t] - ] - - (* Send a client broadcast packet *) - let output_broadcast t ~xid ~yiaddr ~siaddr ~options = - let options = Dhcpv4_option.Packet.to_bytes options in - let options_len = Bytes.length options in - let total_len = options_len + sizeof_dhcp in - let buf = Cstruct.create total_len in - Cstruct.memset buf 0x00; - set_dhcp_op buf (mode_to_int BootRequest); - set_dhcp_htype buf 1; - set_dhcp_hlen buf 6; - set_dhcp_xid buf xid; - set_dhcp_secs buf 10; (* TODO dynamic timer *) - set_dhcp_yiaddr buf (Ipaddr.V4.to_int32 yiaddr); - set_dhcp_siaddr buf (Ipaddr.V4.to_int32 siaddr); - let macaddr = Macaddr.to_bytes t.mac in - set_dhcp_chaddr (macaddr ^ (Bytes.make 10 '\000')) 0 buf; - (* fields intentionally left blank: hops, flags, ciaddr, giaddr, sname, file *) - set_dhcp_cookie buf 0x63825363l; - Cstruct.blit_from_string options 0 buf sizeof_dhcp options_len; - let buf = Cstruct.set_len buf (sizeof_dhcp + options_len) in - Log.info (fun f -> f "Sending DHCP broadcast (length %d)" total_len); - Udp.write ~dst:Ipaddr.V4.broadcast ~src_port:68 ~dst_port:67 t.udp buf - - (* Receive a DHCP UDP packet *) - let input t ~src:_ ~dst:_ ~src_port:_ buf = - let ciaddr = Ipaddr.V4.of_int32 (get_dhcp_ciaddr buf) in - let yiaddr = Ipaddr.V4.of_int32 (get_dhcp_yiaddr buf) in - let siaddr = Ipaddr.V4.of_int32 (get_dhcp_siaddr buf) in - let giaddr = Ipaddr.V4.of_int32 (get_dhcp_giaddr buf) in - let xid = get_dhcp_xid buf in - let of_byte x = - Printf.sprintf "%02x" (Char.code x) in - let chaddr_to_string x = - let chaddr_size = (Bytes.length x) in - let dst_buffer = (Bytes.make (chaddr_size * 2) '\000') in - for i = 0 to (chaddr_size - 1) do - let thischar = of_byte x.[i] in - Bytes.set dst_buffer (i*2) (Bytes.get thischar 0); - Bytes.set dst_buffer ((i*2)+1) (Bytes.get thischar 1) - done; - dst_buffer - in - let chaddr = (chaddr_to_string) (copy_dhcp_chaddr buf) in - let options = Cstruct.(copy buf sizeof_dhcp (len buf - sizeof_dhcp)) in - let packet = Dhcpv4_option.Packet.of_bytes options in - (* For debugging, print out the DHCP response *) - Log.info (fun f -> f - "@[DHCP response:@ \ - input ciaddr %a yiaddr %a@ \ - siaddr %a giaddr %a@ \ - chaddr %s sname %s file %s@]" - Ipaddr.V4.pp_hum ciaddr Ipaddr.V4.pp_hum yiaddr - Ipaddr.V4.pp_hum siaddr Ipaddr.V4.pp_hum giaddr - chaddr (copy_dhcp_sname buf) (copy_dhcp_file buf) - ); - (* See what state our Netif is in and if this packet is useful *) - let open Dhcpv4_option.Packet in - 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 - Log.info (fun f -> f - "DHCP: offer received: %a@\n\ - DHCP options: %s" - Ipaddr.V4.pp_hum yiaddr - (prettyprint packet) - ); - 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 - |_ -> - Log.info (fun f -> f "DHCP: offer not for us"); Lwt.return_unit - 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 - |_ -> Log.info (fun f -> f "DHCP: ack not for us"); Lwt.return_unit - end - | Shutting_down -> Lwt.return_unit - | Lease_held _ -> Log.info (fun f -> f "DHCP input: lease already held"); Lwt.return_unit - | Disabled -> Log.info (fun f -> f "DHCP input: disabled"); Lwt.return_unit - - (* Start a DHCP discovery off on an interface *) - let start_discovery t = - Time.sleep_ns (Duration.of_ms 200) - >>= fun () -> - let xid = Randomconv.int32 Random.generate in - let yiaddr = Ipaddr.V4.any in - let siaddr = Ipaddr.V4.any in - let options = { Dhcpv4_option.Packet.op=`Discover; opts= [ - (`Parameter_request [`Subnet_mask; `Router; `DNS_server; `Broadcast]); - (`Host_name "miragevm") - ] } in - Log.info (fun f -> f "DHCP: start discovery"); - t.state <- Request_sent xid; - output_broadcast t ~xid ~yiaddr ~siaddr ~options >>= fun () -> - Lwt.return_unit - - (* 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 - >>= fun () -> - Time.sleep_ns (Duration.of_sec 10) - >>= fun () -> - dhcp_thread t - |Shutting_down -> - Log.info (fun f -> f "DHCP thread: done"); Lwt.return_unit - |_ -> - (* TODO: This should be looking at the lease time *) - Time.sleep_ns (Duration.of_hour 1) - >>= fun () -> - dhcp_thread t - - let pp_opt pp f = function - | None -> Format.pp_print_string f "None" - | Some x -> pp f x - - (* Create a DHCP thread *) - let create mac udp = - let state = Disabled in - (* For now, just block on the first offer - and shut down DHCP after. TODO: full protocol *) - let offer_stream, offer_push = Lwt_stream.create () in - let new_offer info = - Log.info (fun f -> f "DHCP: offer received@\nIPv4: %a@\nNetmask: %a\nGateways: [%s]" - Ipaddr.V4.pp_hum info.ip_addr - (pp_opt Ipaddr.V4.pp_hum) info.netmask - (String.concat ", " (List.map Ipaddr.V4.to_string info.gateways))); - offer_push (Some info); - Lwt.return_unit - in - let t = { mac; udp; state; new_offer } in - (* TODO cancellation *) - let _ = dhcp_thread t in - t, offer_stream - - let listen t ~dst_port = - match dst_port with - | 68 (* TODO services module from Uri? *) -> Some (input t) - | _ -> None -end diff --git a/lib/dhcp/dhcpv4.mldylib b/lib/dhcp/dhcpv4.mldylib deleted file mode 100644 index 3c2d4cfcc..000000000 --- a/lib/dhcp/dhcpv4.mldylib +++ /dev/null @@ -1,5 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 6fde50ae603bc1fc44bb572206fbe6fe) -Dhcpv4_option -Dhcp_clientv4 -# OASIS_STOP diff --git a/lib/dhcp/dhcpv4.mllib b/lib/dhcp/dhcpv4.mllib deleted file mode 100644 index 3c2d4cfcc..000000000 --- a/lib/dhcp/dhcpv4.mllib +++ /dev/null @@ -1,5 +0,0 @@ -# OASIS_START -# DO NOT EDIT (digest: 6fde50ae603bc1fc44bb572206fbe6fe) -Dhcpv4_option -Dhcp_clientv4 -# OASIS_STOP diff --git a/lib/dhcp/dhcpv4_option.ml b/lib/dhcp/dhcpv4_option.ml deleted file mode 100644 index 21df5da38..000000000 --- a/lib/dhcp/dhcpv4_option.ml +++ /dev/null @@ -1,425 +0,0 @@ -(* - * Copyright (c) 2006-2010 Anil Madhavapeddy - * - * 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 Printf - -(* 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 Ipaddr.V4.t - | `Time_offset of string - | `Router of Ipaddr.V4.t list - | `Broadcast of Ipaddr.V4.t - | `Time_server of Ipaddr.V4.t list - | `Name_server of Ipaddr.V4.t list - | `DNS_server of Ipaddr.V4.t list - | `Netbios_name_server of Ipaddr.V4.t list - | `Host_name of string - | `Domain_name of string - | `Requested_ip of Ipaddr.V4.t - | `Interface_mtu of int - | `Lease_time of int32 - | `Message_type of op - | `Server_identifier of Ipaddr.V4.t - | `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 (Ipaddr.V4.to_string ip) in - let ip_list s ips = sprintf "%s(%s)" s (String.concat "," (List.map Ipaddr.V4.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 _ -> "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) (Bytes.length x) - | `End -> "End" - -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 - Ipaddr.V4.of_int32 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 = Bytes.make 1 (Char.chr (t_to_code x)) - - let uint32_to_bytes s = - let x = Bytes.create 4 in - let (>!) x y = Int32.logand (Int32.shift_right x y) 255l in - Bytes.set x 0 (Char.chr (Int32.to_int (s >! 24))); - Bytes.set x 1 (Char.chr (Int32.to_int (s >! 16))); - Bytes.set x 2 (Char.chr (Int32.to_int (s >! 8))); - Bytes.set x 3 (Char.chr (Int32.to_int (s >! 0))); - x - - let uint16_to_bytes s = - let x = Bytes.create 2 in - Bytes.set x 0 (Char.chr (s land 255)); - Bytes.set x 1 (Char.chr ((s lsl 8) land 255)); - x - - let size x = Bytes.make 1 (Char.chr x) - let str c x = to_byte c :: (size (Bytes.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 ip_list c ips = - let x = List.map (fun x -> (uint32_to_bytes (Ipaddr.V4.to_int32 x))) ips in - to_byte c :: (size (List.length x * 4)) :: x - let ip_one c x = uint32 c (Ipaddr.V4.to_int32 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 _ -> 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 -> Bytes.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 _ -> - assert false (* not supported yet, requires annoying DNS compression *) - |`End -> [to_byte `End] - |`Unknown (c,x) -> [ (Bytes.make 1 c); x ] - in Bytes.concat "" bits - - let options mtype xs = - let buf = Bytes.make 312 '\000' in - let p = Bytes.concat "" (List.map to_bytes (`Message_type mtype :: xs @ [`End])) in - (* DHCP packets have minimum length, hence the blit into buf *) - Bytes.blit p 0 buf 0 (Bytes.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 = Bytes.get buf !pos in - pos := !pos + 1; - r in - let getint () = (* Get one integer *) - Char.code (getc ()) in - let slice len = (* Get a substring *) - if (!pos + len) > (Bytes.length buf) || !pos > (Bytes.length buf) - then raise (Error (sprintf "Requested too much string at %d %d (%d)" !pos len (Bytes.length buf) )); - let r = Bytes.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_number len = (* Get a number from len bytes *) - let bytestring = slice len in - let r = ref 0 in - for i = 0 to (len - 1) do - let bitshift = ((len - (i + 1)) * 8) in - r := ((Char.code bytestring.[i]) lsl bitshift) + !r; - done; - !r 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 len = getint () in - cont (`Max_size (get_number len)) - |`Interface_mtu -> - (* TODO according to some printf/tcpdump testing, this is being set but not - * respected by the unikernel; https://github.com/mirage/mirage/issues/238 *) - let len = getint () in - cont (`Interface_mtu (get_number len)) - |`Client_id -> - let len = getint () in - let _ = getint () in (* disregard type information *) - 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 diff --git a/lib/dhcp/dhcpv4_option.mli b/lib/dhcp/dhcpv4_option.mli deleted file mode 100644 index eefad340b..000000000 --- a/lib/dhcp/dhcpv4_option.mli +++ /dev/null @@ -1,109 +0,0 @@ -(* - * Copyright (c) 2006-2011 Anil Madhavapeddy - * - * 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 Ipaddr.V4.t - | `Client_id of string - | `DNS_server of Ipaddr.V4.t 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 Ipaddr.V4.t list - | `Netbios_name_server of Ipaddr.V4.t list - | `Pad - | `Parameter_request of msg list - | `Requested_ip of Ipaddr.V4.t - | `Router of Ipaddr.V4.t list - | `Server_identifier of Ipaddr.V4.t - | `Subnet_mask of Ipaddr.V4.t - | `Time_offset of string - | `Time_server of Ipaddr.V4.t 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_of_bytes : string -> Ipaddr.V4.t -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 -> Ipaddr.V4.t list -> string list - val ip_one : msg -> Ipaddr.V4.t -> 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 diff --git a/lib/ipv4/ipv4.ml b/lib/ipv4/ipv4.ml deleted file mode 100644 index c5f0dc17c..000000000 --- a/lib/ipv4/ipv4.ml +++ /dev/null @@ -1,206 +0,0 @@ -(* - * Copyright (c) 2010-2011 Anil Madhavapeddy - * - * 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 l 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.Infix -open Result - -let src = Logs.Src.create "ipv4" ~doc:"Mirage IPv4" -module Log = (val Logs.src_log src : Logs.LOG) - -module Make(Ethif: V1_LWT.ETHIF) (Arpv4 : V1_LWT.ARP) = struct - - (** IO operation errors *) - type error = [ - | `Unknown of string (** an undiagnosed error *) - | `Unimplemented (** operation not yet implemented in the code *) - ] - - type ethif = Ethif.t - type 'a io = 'a Lwt.t - type buffer = Cstruct.t - type ipaddr = Ipaddr.V4.t - type prefix = Ipaddr.V4.t - type callback = src:ipaddr -> dst:ipaddr -> buffer -> unit Lwt.t - - type t = { - ethif : Ethif.t; - arp : Arpv4.t; - mutable ip: Ipaddr.V4.t; - mutable netmask: Ipaddr.V4.t; - mutable gateways: Ipaddr.V4.t list; - } - - module Routing = struct - - exception No_route_to_destination_address of Ipaddr.V4.t - - let is_local t ip = - let ipand a b = Int32.logand (Ipaddr.V4.to_int32 a) (Ipaddr.V4.to_int32 b) in - (ipand t.ip t.netmask) = (ipand ip t.netmask) - - (* RFC 1112: 01-00-5E-00-00-00 ORed with lower 23 bits of the ip address *) - let mac_of_multicast ip = - let ipb = Ipaddr.V4.to_bytes ip in - let macb = Bytes.create 6 in - Bytes.set macb 0 (Char.chr 0x01); - Bytes.set macb 1 (Char.chr 0x00); - Bytes.set macb 2 (Char.chr 0x5E); - Bytes.set macb 3 (Char.chr ((Char.code ipb.[1]) land 0x7F)); - Bytes.set macb 4 (Bytes.get ipb 2); - Bytes.set macb 5 (Bytes.get ipb 3); - Macaddr.of_bytes_exn macb - - let destination_mac t = - function - |ip when ip = Ipaddr.V4.broadcast || ip = Ipaddr.V4.any -> (* Broadcast *) - Lwt.return Macaddr.broadcast - |ip when is_local t ip -> (* Local *) - Arpv4.query t.arp ip >>= begin function - | `Ok mac -> Lwt.return mac - | `Timeout -> Lwt.fail (No_route_to_destination_address ip) - end - |ip when Ipaddr.V4.is_multicast ip -> - Lwt.return (mac_of_multicast ip) - |ip -> begin (* Gateway *) - match t.gateways with - |hd::_ -> - Arpv4.query t.arp hd >>= begin function - | `Ok mac -> Lwt.return mac - | `Timeout -> - Log.info (fun f -> f "IP.output: could not send to %a: failed to contact gateway %a" - Ipaddr.V4.pp_hum ip Ipaddr.V4.pp_hum hd); - Lwt.fail (No_route_to_destination_address ip) - end - |[] -> - Log.info (fun f -> f "IP.output: no route to %a (no default gateway is configured)" Ipaddr.V4.pp_hum ip); - Lwt.fail (No_route_to_destination_address ip) - end - end - - let adjust_output_header ~dmac ~tlen frame = - let open Ipv4_wire in - Ethif_wire.set_ethernet_dst dmac 0 frame; - let buf = Cstruct.sub frame Ethif_wire.sizeof_ethernet 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 = Tcpip_checksum.ones_complement buf in - set_ipv4_csum buf checksum - - let allocate_frame t ~(dst:ipaddr) ~(proto : [`ICMP | `TCP | `UDP]) : (buffer * int) = - let open Ipv4_wire in - let ethernet_frame = Io_page.to_cstruct (Io_page.get 1) in - let len = Ethif_wire.sizeof_ethernet + sizeof_ipv4 in - let eth_header = Ethif_packet.({ethertype = Ethif_wire.IPv4; - source = Ethif.mac t.ethif; - destination = Macaddr.broadcast}) in - match Ethif_packet.Marshal.into_cstruct eth_header ethernet_frame with - | Error s -> - Log.info (fun f -> f "IP.allocate_frame: could not print ethernet header: %s" s); - raise (Invalid_argument "writing ethif header to ipv4.allocate_frame failed") - | Ok () -> - let buf = Cstruct.shift ethernet_frame Ethif_wire.sizeof_ethernet in - (* TODO: why 38 for TTL? *) - let ipv4_header = Ipv4_packet.({options = Cstruct.create 0; - src = t.ip; dst; ttl = 38; - proto = Ipv4_packet.Marshal.protocol_to_int proto; }) in - (* set the payload to 0, since we don't know what it'll be yet *) - (* the caller needs to then use [writev] or [write] to output the buffer; - otherwise length, id, and checksum won't be set properly *) - match Ipv4_packet.Marshal.into_cstruct ~payload:(Cstruct.create 0) ipv4_header buf with - | Error s -> - Log.info (fun f -> f "IP.allocate_frame: could not print IPv4 header: %s" s); - raise (Invalid_argument "writing ipv4 header to ipv4.allocate_frame failed") - | Ok () -> - (ethernet_frame, len) - - let writev t frame bufs = - let v4_frame = Cstruct.shift frame Ethif_wire.sizeof_ethernet in - let dst = Ipaddr.V4.of_int32 (Ipv4_wire.get_ipv4_dst v4_frame) in - (* Something of a layer violation here, but ARP is awkward *) - Routing.destination_mac t dst >|= Macaddr.to_bytes >>= fun dmac -> - let tlen = Cstruct.len frame + Cstruct.lenv bufs - Ethif_wire.sizeof_ethernet in - adjust_output_header ~dmac ~tlen frame; - Ethif.writev t.ethif (frame :: bufs) - - let write t frame buf = - writev t frame [buf] - - (* TODO: ought we to check to make sure the destination is relevant here? currently we'll process all incoming packets, regardless of destination address *) - let input _t ~tcp ~udp ~default buf = - let open Ipv4_packet in - match Unmarshal.of_cstruct buf with - | Error s -> - Log.info (fun f -> f "IP.input: unparseable header (%s): %S" s (Cstruct.to_string buf)); - Lwt.return_unit - | Ok (packet, payload) -> - match Unmarshal.int_to_protocol packet.proto, Cstruct.len payload with - | Some _, 0 -> - (* Don't pass on empty buffers as payloads to known protocols, as they have no relevant headers *) - Lwt.return_unit - | None, 0 -> (* we don't know anything about the protocol; an empty - payload may be meaningful somehow? *) - default ~proto:packet.proto ~src:packet.src ~dst:packet.dst payload - | Some `TCP, _ -> tcp ~src:packet.src ~dst:packet.dst payload - | Some `UDP, _ -> udp ~src:packet.src ~dst:packet.dst payload - | Some `ICMP, _ | None, _ -> - default ~proto:packet.proto ~src:packet.src ~dst:packet.dst payload - - let connect - ?(ip=Ipaddr.V4.any) - ?(netmask=Ipaddr.V4.any) - ?(gateways=[]) ethif arp = - let t = { ethif; arp; ip; netmask; gateways } in - Lwt.return t - - let disconnect _ = Lwt.return_unit - - let set_ip t ip = - t.ip <- ip; - (* Inform ARP layer of new IP *) - Arpv4.add_ip t.arp ip - - let get_ip t = [t.ip] - - let set_ip_netmask t netmask = - t.netmask <- netmask; - Lwt.return_unit - - let get_ip_netmasks t = [t.netmask] - - let set_ip_gateways t gateways = - t.gateways <- gateways; - Lwt.return_unit - - let get_ip_gateways { gateways; _ } = gateways - - let pseudoheader t ~dst ~proto len = - Ipv4_packet.Marshal.pseudoheader ~src:t.ip ~dst ~proto len - - let checksum frame bufs = - let packet = Cstruct.shift frame Ethif_wire.sizeof_ethernet in - Ipv4_wire.set_ipv4_csum packet 0; - Tcpip_checksum.ones_complement_list (packet :: bufs) - - let src t ~dst:_ = - t.ip - - type uipaddr = Ipaddr.t - let to_uipaddr ip = Ipaddr.V4 ip - let of_uipaddr = Ipaddr.to_v4 - -end diff --git a/lib/ipv4/ipv4.mldylib b/lib/ipv4/ipv4.mldylib index 3ad95c1a9..cbabc8ff2 100644 --- a/lib/ipv4/ipv4.mldylib +++ b/lib/ipv4/ipv4.mldylib @@ -1,6 +1,8 @@ # OASIS_START -# DO NOT EDIT (digest: 2370d09942645f75c25f09f7288335f2) -Ipv4 +# DO NOT EDIT (digest: 4492d2225e4aed6533034d3482e7bb18) +Static_ipv4 Ipv4_wire Ipv4_packet +Ipv4_common +Routing # OASIS_STOP diff --git a/lib/ipv4/ipv4.mllib b/lib/ipv4/ipv4.mllib index 3ad95c1a9..cbabc8ff2 100644 --- a/lib/ipv4/ipv4.mllib +++ b/lib/ipv4/ipv4.mllib @@ -1,6 +1,8 @@ # OASIS_START -# DO NOT EDIT (digest: 2370d09942645f75c25f09f7288335f2) -Ipv4 +# DO NOT EDIT (digest: 4492d2225e4aed6533034d3482e7bb18) +Static_ipv4 Ipv4_wire Ipv4_packet +Ipv4_common +Routing # OASIS_STOP diff --git a/lib/ipv4/ipv4_common.ml b/lib/ipv4/ipv4_common.ml new file mode 100644 index 000000000..98d5f2bf4 --- /dev/null +++ b/lib/ipv4/ipv4_common.ml @@ -0,0 +1,40 @@ +let adjust_output_header ~dmac ~tlen frame = + let open Ipv4_wire in + Ethif_wire.set_ethernet_dst dmac 0 frame; + let buf = Cstruct.sub frame Ethif_wire.sizeof_ethernet 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 = Tcpip_checksum.ones_complement buf in + set_ipv4_csum buf checksum + + let allocate_frame ~src ~source ~(dst:Ipaddr.V4.t) ~(proto : [`ICMP | `TCP | `UDP]) : (Cstruct.t * int) = + let open Ipv4_wire in + let ethernet_frame = Io_page.to_cstruct (Io_page.get 1) in + let len = Ethif_wire.sizeof_ethernet + sizeof_ipv4 in + let eth_header = Ethif_packet.({ethertype = Ethif_wire.IPv4; + source; + destination = Macaddr.broadcast}) in + match Ethif_packet.Marshal.into_cstruct eth_header ethernet_frame with + | Error _s -> + raise (Invalid_argument "writing ethif header to ipv4.allocate_frame failed") + | Ok () -> + let buf = Cstruct.shift ethernet_frame Ethif_wire.sizeof_ethernet in + (* TODO: why 38 for TTL? *) + let ipv4_header = Ipv4_packet.({options = Cstruct.create 0; + src; dst; ttl = 38; + proto = Ipv4_packet.Marshal.protocol_to_int proto; }) in + (* set the payload to 0, since we don't know what it'll be yet *) + (* the caller needs to then use [writev] or [write] to output the buffer; + otherwise length, id, and checksum won't be set properly *) + match Ipv4_packet.Marshal.into_cstruct ~payload:(Cstruct.create 0) ipv4_header buf with + | Error _s -> + raise (Invalid_argument "writing ipv4 header to ipv4.allocate_frame failed") + | Ok () -> + (ethernet_frame, len) + + let checksum frame bufs = + let packet = Cstruct.shift frame Ethif_wire.sizeof_ethernet in + Ipv4_wire.set_ipv4_csum packet 0; + Tcpip_checksum.ones_complement_list (packet :: bufs) diff --git a/lib/ipv4/routing.ml b/lib/ipv4/routing.ml new file mode 100644 index 000000000..3c3c84625 --- /dev/null +++ b/lib/ipv4/routing.ml @@ -0,0 +1,42 @@ +(* RFC 1112: 01-00-5E-00-00-00 ORed with lower 23 bits of the ip address *) +let mac_of_multicast ip = + let ipb = Ipaddr.V4.to_bytes ip in + let macb = Bytes.create 6 in + Bytes.set macb 0 (Char.chr 0x01); + Bytes.set macb 1 (Char.chr 0x00); + Bytes.set macb 2 (Char.chr 0x5E); + Bytes.set macb 3 (Char.chr ((Char.code ipb.[1]) land 0x7F)); + Bytes.set macb 4 (Bytes.get ipb 2); + Bytes.set macb 5 (Bytes.get ipb 3); + Macaddr.of_bytes_exn macb + +exception No_route_to_destination_address of Ipaddr.V4.t + +module Make(Log : Logs.LOG) (A : V1_LWT.ARP) = struct + open Lwt.Infix + + let destination_mac network gateway arp = function + |ip when ip = Ipaddr.V4.broadcast || ip = Ipaddr.V4.any -> (* Broadcast *) + Lwt.return Macaddr.broadcast + |ip when Ipaddr.V4.is_multicast ip -> + Lwt.return (mac_of_multicast ip) + |ip when Ipaddr.V4.Prefix.mem ip network -> (* Local *) + A.query arp ip >>= begin function + | `Ok mac -> Lwt.return mac + | `Timeout -> + Log.info (fun f -> f "IP.output: could not determine link-layer address for local network (%a) ip %a" Ipaddr.V4.Prefix.pp_hum network Ipaddr.V4.pp_hum ip); + Lwt.fail (No_route_to_destination_address ip) + end + |ip -> (* Gateway *) + match gateway with + | None -> + Log.info (fun f -> f "IP.output: no route to %a (no default gateway is configured)" Ipaddr.V4.pp_hum ip); + Lwt.fail (No_route_to_destination_address ip) + | Some gateway -> + A.query arp gateway >>= function + | `Ok mac -> Lwt.return mac + | `Timeout -> + Log.info (fun f -> f "IP.output: could not send to %a: failed to contact gateway %a" + Ipaddr.V4.pp_hum ip Ipaddr.V4.pp_hum gateway); + Lwt.fail (No_route_to_destination_address ip) +end diff --git a/lib/ipv4/static_ipv4.ml b/lib/ipv4/static_ipv4.ml new file mode 100644 index 000000000..53a8884c9 --- /dev/null +++ b/lib/ipv4/static_ipv4.ml @@ -0,0 +1,119 @@ +(* + * Copyright (c) 2010-2011 Anil Madhavapeddy + * + * 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 l 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.Infix +open Result + +let src = Logs.Src.create "ipv4" ~doc:"Mirage IPv4" +module Log = (val Logs.src_log src : Logs.LOG) + +module Make(Ethif: V1_LWT.ETHIF) (Arpv4 : V1_LWT.ARP) = struct + module Routing = Routing.Make(Log)(Arpv4) + exception No_route_to_destination_address of Ipaddr.V4.t + (** IO operation errors *) + type error = [ + | `Unknown of string (** an undiagnosed error *) + | `Unimplemented (** operation not yet implemented in the code *) + ] + + type ethif = Ethif.t + type 'a io = 'a Lwt.t + type buffer = Cstruct.t + type ipaddr = Ipaddr.V4.t + type prefix = Ipaddr.V4.Prefix.t + type callback = src:ipaddr -> dst:ipaddr -> buffer -> unit Lwt.t + + type t = { + ethif : Ethif.t; + arp : Arpv4.t; + mutable ip: Ipaddr.V4.t; + network: Ipaddr.V4.Prefix.t; + mutable gateway: Ipaddr.V4.t option; + } + + let adjust_output_header = Ipv4_common.adjust_output_header + + let allocate_frame t ~(dst:ipaddr) ~(proto : [`ICMP | `TCP | `UDP]) : (buffer * int) = + Ipv4_common.allocate_frame ~src:t.ip ~source:(Ethif.mac t.ethif) ~dst ~proto + + let writev t frame bufs = + let v4_frame = Cstruct.shift frame Ethif_wire.sizeof_ethernet in + let dst = Ipaddr.V4.of_int32 (Ipv4_wire.get_ipv4_dst v4_frame) in + (* Something of a layer violation here, but ARP is awkward *) + Routing.destination_mac t.network t.gateway t.arp dst >|= + Macaddr.to_bytes >>= fun dmac -> + let tlen = Cstruct.len frame + Cstruct.lenv bufs - Ethif_wire.sizeof_ethernet in + adjust_output_header ~dmac ~tlen frame; + Ethif.writev t.ethif (frame :: bufs) + + let write t frame buf = + writev t frame [buf] + + (* TODO: ought we to check to make sure the destination is relevant here? currently we'll process all incoming packets, regardless of destination address *) + let input _t ~tcp ~udp ~default buf = + let open Ipv4_packet in + match Unmarshal.of_cstruct buf with + | Error s -> + Log.info (fun f -> f "IP.input: unparseable header (%s): %S" s (Cstruct.to_string buf)); + Lwt.return_unit + | Ok (packet, payload) -> + match Unmarshal.int_to_protocol packet.proto, Cstruct.len payload with + | Some _, 0 -> + (* Don't pass on empty buffers as payloads to known protocols, as they have no relevant headers *) + Lwt.return_unit + | None, 0 -> (* we don't know anything about the protocol; an empty + payload may be meaningful somehow? *) + default ~proto:packet.proto ~src:packet.src ~dst:packet.dst payload + | Some `TCP, _ -> tcp ~src:packet.src ~dst:packet.dst payload + | Some `UDP, _ -> udp ~src:packet.src ~dst:packet.dst payload + | Some `ICMP, _ | None, _ -> + default ~proto:packet.proto ~src:packet.src ~dst:packet.dst payload + + let connect + ?(ip=Ipaddr.V4.any) + ?(network=Ipaddr.V4.Prefix.make 0 Ipaddr.V4.any) + ?(gateway=None) ethif arp = + match Ipaddr.V4.Prefix.mem ip network with + | false -> + Log.warn (fun f -> f "IPv4: ip %a is not in the prefix %a" Ipaddr.V4.pp_hum ip Ipaddr.V4.Prefix.pp_hum network); + Lwt.fail_with "given IP is not in the network provided" + | true -> + Arpv4.set_ips arp [ip] >>= fun () -> + let t = { ethif; arp; ip; network; gateway } in + Lwt.return t + + let disconnect _ = Lwt.return_unit + + let set_ip t ip = + t.ip <- ip; + (* Inform ARP layer of new IP *) + Arpv4.set_ips t.arp [ip] + + let get_ip t = [t.ip] + + let pseudoheader t ~dst ~proto len = + Ipv4_packet.Marshal.pseudoheader ~src:t.ip ~dst ~proto len + + let checksum = Ipv4_common.checksum + + let src t ~dst:_ = + t.ip + + type uipaddr = Ipaddr.t + let to_uipaddr ip = Ipaddr.V4 ip + let of_uipaddr = Ipaddr.to_v4 + +end diff --git a/lib/ipv4/ipv4.mli b/lib/ipv4/static_ipv4.mli similarity index 73% rename from lib/ipv4/ipv4.mli rename to lib/ipv4/static_ipv4.mli index 0a66883dd..20849a2b6 100644 --- a/lib/ipv4/ipv4.mli +++ b/lib/ipv4/static_ipv4.mli @@ -15,20 +15,16 @@ *) module Make (N:V1_LWT.ETHIF) (A: V1_LWT.ARP) : sig - module Routing : sig - (* this exception can be thrown by `write` or `writev` when the destination - IP address's link-layer address can't be found by ARP *) - exception No_route_to_destination_address of Ipaddr.V4.t - end include V1_LWT.IPV4 with type ethif = N.t + exception No_route_to_destination_address of Ipaddr.V4.t val connect : ?ip:Ipaddr.V4.t -> - ?netmask:Ipaddr.V4.t -> - ?gateways:Ipaddr.V4.t list -> + ?network:Ipaddr.V4.Prefix.t -> + ?gateway:Ipaddr.V4.t option -> ethif -> A.t -> t Lwt.t (** Connect to an ipv4 device. Default ip is {!Ipaddr.V4.any} - Default netmask is {!Ipaddr.V4.any} - Default gateways are [[]]. *) + Default network is {!Ipaddr.V4.any}/0 + Default gateway is None. *) end diff --git a/lib/tcpip_stack_direct.ml b/lib/tcpip_stack_direct.ml index fbb03b7cd..d4f1b3015 100644 --- a/lib/tcpip_stack_direct.ml +++ b/lib/tcpip_stack_direct.ml @@ -40,10 +40,9 @@ module Make struct type +'a io = 'a Lwt.t - type ('a,'b) config = ('a,'b) V1_LWT.stackv4_config + type 'a config = 'a V1_LWT.stackv4_config type netif = Netif.t - type mode = V1_LWT.direct_stack_config - type id = (netif, mode) config + type id = netif config type buffer = Cstruct.t type ipv4addr = Ipaddr.V4.t type tcpv4 = Tcpv4.t @@ -53,11 +52,9 @@ struct module UDPV4 = Udpv4 module TCPV4 = Tcpv4 module IPV4 = Ipv4 - module Dhcp = Dhcp_clientv4.Make(Time)(Random)(Udpv4) type t = { id : id; - mode : mode; netif : Netif.t; ethif : Ethif.t; arpv4 : Arpv4.t; @@ -94,44 +91,6 @@ struct | None -> Format.pp_print_string f "None" | Some x -> pp f x - let configure_dhcp t info = - Ipv4.set_ip t.ipv4 info.Dhcp.ip_addr - >>= fun () -> - (match info.Dhcp.netmask with - | Some nm -> Ipv4.set_ip_netmask t.ipv4 nm - | None -> Lwt.return_unit) - >>= fun () -> - Ipv4.set_ip_gateways t.ipv4 info.Dhcp.gateways - >|= fun () -> - Log.info (fun f -> f "DHCP offer received and bound to %a nm %a gw [%s]" - Ipaddr.V4.pp_hum info.Dhcp.ip_addr - (pp_opt Ipaddr.V4.pp_hum) info.Dhcp.netmask - (String.concat ", " (List.map Ipaddr.V4.to_string info.Dhcp.gateways)) - ) - - let configure t config = - match config with - | `DHCP -> begin - (* TODO: spawn a background thread to reconfigure the interface - when future offers are received. *) - let dhcp, offers = Dhcp.create (Ethif.mac t.ethif) t.udpv4 in - listen_udpv4 t ~port:68 (Dhcp.input dhcp); - (* TODO: stop listening to this port when done with DHCP. *) - Lwt_stream.get offers >>= function - | None -> Log.info (fun f -> f "No DHCP offer received"); Lwt.return () - | Some offer -> configure_dhcp t offer - end - | `IPv4 (addr, netmask, gateways) -> - Log.info (fun f -> f "Manager: Interface to %a nm %a gw [%s]" - Ipaddr.V4.pp_hum addr - Ipaddr.V4.pp_hum netmask - (String.concat ", " (List.map Ipaddr.V4.to_string gateways))); - Ipv4.set_ip t.ipv4 addr - >>= fun () -> - Ipv4.set_ip_netmask t.ipv4 netmask - >>= fun () -> - Ipv4.set_ip_gateways t.ipv4 gateways - let udpv4_listeners t ~dst_port = try Some (Hashtbl.find t.udpv4_listeners dst_port) with Not_found -> None @@ -170,23 +129,13 @@ struct Lwt.return_unit let connect id ethif arpv4 ipv4 icmpv4 udpv4 tcpv4 = - let { V1_LWT.interface = netif; mode; _ } = id in + let { V1_LWT.interface = netif; _ } = id in Log.info (fun f -> f "Manager: connect"); let udpv4_listeners = Hashtbl.create 7 in let tcpv4_listeners = Hashtbl.create 7 in - let t = { id; mode; netif; ethif; arpv4; ipv4; icmpv4; tcpv4; udpv4; + let t = { id; netif; ethif; arpv4; ipv4; icmpv4; tcpv4; udpv4; udpv4_listeners; tcpv4_listeners } in - Log.info (fun f -> f "Manager: configuring"); - let _ = listen t in - configure t t.mode - >>= fun () -> - (* TODO: this is fine for now, because the DHCP state machine isn't fully - implemented and its thread will terminate after one successful lease - transaction. For a DHCP thread that runs forever, `configure` will need - to spawn a background thread, but we need to consider how to inform the - application stack that the IP address has changed (perhaps via a control - Lwt_stream that the application can ignore if it doesn't care). *) - Log.info (fun f -> f "Manager: configuration done"); + Log.info (fun f -> f "Manager: stack assembled!"); Lwt.return t let disconnect _t = diff --git a/lib/tcpip_stack_direct.mli b/lib/tcpip_stack_direct.mli index 7d64d7532..4147a3605 100644 --- a/lib/tcpip_stack_direct.mli +++ b/lib/tcpip_stack_direct.mli @@ -33,14 +33,13 @@ module Make (Tcpv4 : TCPV4_DIRECT with type ip = Ipv4.t) : sig include V1_LWT.STACKV4 with type netif = Netif.t - and type mode = V1_LWT.direct_stack_config and type udpv4 = Udpv4.t and type tcpv4 = Tcpv4.t and type ipv4 = Ipv4.t and module IPV4 = Ipv4 and module TCPV4 = Tcpv4 and module UDPV4 = Udpv4 - val connect : (netif, mode) V1_LWT.stackv4_config -> + val connect : netif V1_LWT.stackv4_config -> Ethif.t -> Arpv4.t -> Ipv4.t -> Icmpv4.t -> Udpv4.t -> Tcpv4.t -> t Lwt.t end diff --git a/lib_test/test_connect.ml b/lib_test/test_connect.ml index 0aedc497b..3a5ea4b3a 100644 --- a/lib_test/test_connect.ml +++ b/lib_test/test_connect.ml @@ -25,8 +25,8 @@ module Log = (val Logs.src_log src : Logs.LOG) module Test_connect (B : Vnetif_backends.Backend) = struct module V = VNETIF_STACK (B) - let netmask = Ipaddr.V4.of_string_exn "255.255.255.0" - let gw = Ipaddr.V4.of_string_exn "10.0.0.1" + let netmask = 24 + let gw = Some (Ipaddr.V4.of_string_exn "10.0.0.1") let client_ip = Ipaddr.V4.of_string_exn "10.0.0.101" let server_ip = Ipaddr.V4.of_string_exn "10.0.0.100" let test_string = "Hello world from Mirage 123456789...." @@ -62,13 +62,15 @@ module Test_connect (B : Vnetif_backends.Backend) = struct (Lwt_unix.sleep timeout >>= fun () -> fail "connect test timedout after %f seconds" timeout) ; - (V.create_stack backend server_ip netmask [gw] >>= fun s1 -> + (V.create_stack backend server_ip netmask gw >>= fun s1 -> V.Stackv4.listen_tcpv4 s1 ~port:80 (fun f -> accept f test_string); V.Stackv4.listen s1) ; (Lwt_unix.sleep 0.1 >>= fun () -> - V.create_stack backend client_ip netmask [gw] >>= fun s2 -> - let conn = V.Stackv4.TCPV4.create_connection (V.Stackv4.tcpv4 s2) in + V.create_stack backend client_ip netmask gw >>= fun s2 -> + Lwt.pick [ + V.Stackv4.listen s2; + (let conn = V.Stackv4.TCPV4.create_connection (V.Stackv4.tcpv4 s2) in or_error "connect" conn (server_ip, 80) >>= fun flow -> Logs.debug (fun f -> f "Connected to other end..."); V.Stackv4.TCPV4.write flow (Cstruct.of_string test_string) >>= function @@ -78,7 +80,7 @@ module Test_connect (B : Vnetif_backends.Backend) = struct Logs.debug (fun f -> f "wrote hello world"); V.Stackv4.TCPV4.close flow >>= fun () -> Lwt_unix.sleep 1.0 >>= fun () -> (* record some traffic after close *) - Lwt.return_unit) ] >>= fun () -> + Lwt.return_unit)]) ] >>= fun () -> Lwt.return_unit diff --git a/lib_test/test_icmpv4.ml b/lib_test/test_icmpv4.ml index 97cb23832..2f1a77216 100644 --- a/lib_test/test_icmpv4.ml +++ b/lib_test/test_icmpv4.ml @@ -15,7 +15,7 @@ type decomposed = { ethernet_header : Ethif_packet.t; } -module Ip = Ipv4.Make(E)(Static_arp) +module Ip = Static_ipv4.Make(E)(Static_arp) module Icmp = Icmpv4.Make(Ip) module Udp = Udp.Make(Ip) @@ -36,27 +36,27 @@ let testbind x y = | Error s -> Alcotest.fail s let (>>=?) = testbind +(* some default addresses which will be on the same class C *) +let listener_address = Ipaddr.V4.of_string_exn "192.168.222.1" +let speaker_address = Ipaddr.V4.of_string_exn "192.168.222.10" + let slowly fn = Time.sleep_ns (Duration.of_ms 100) >>= fun () -> fn >>= fun () -> Time.sleep_ns (Duration.of_ms 100) let get_stack ?(backend = B.create ~use_async_readers:true - ~yield:(fun() -> Lwt_main.yield ()) ()) () = + ~yield:(fun() -> Lwt_main.yield ()) ()) + ip = + let network = Ipaddr.V4.Prefix.make 24 listener_address in + let gateway = None in Mclock.connect () >>= fun clock -> V.connect backend >>= fun netif -> E.connect netif >>= fun ethif -> Static_arp.connect ethif clock >>= fun arp -> - Ip.connect ethif arp >>= fun ip -> + Ip.connect ~ip ~network ~gateway ethif arp >>= fun ip -> Icmp.connect ip >>= fun icmp -> Udp.connect ip >>= fun udp -> Lwt.return { backend; netif; ethif; arp; ip; icmp; udp } -(* assume a class C network with no default gateway *) -let configure ip stack = - Ip.set_ip stack.ip ip >>= fun () -> - Ip.set_ip_netmask stack.ip (Ipaddr.V4.of_string_exn "255.255.255.0") >>= fun - () -> - Lwt.return stack - let icmp_listen stack fn = let noop = fun ~src:_ ~dst:_ _buf -> Lwt.return_unit in V.listen stack.netif (* some buffer -> (unit, error) result io *) @@ -67,9 +67,6 @@ let icmp_listen stack fn = ~tcp:noop ~udp:noop ~default:(fun ~proto -> match proto with | 1 -> fn | _ -> noop))) >|= fun _ -> () -(* some default addresses which will be on the same class C *) -let listener_address = Ipaddr.V4.of_string_exn "192.168.222.1" -let speaker_address = Ipaddr.V4.of_string_exn "192.168.222.10" let inform_arp stack = Static_arp.add_entry stack.arp let mac_of_stack stack = E.mac stack.ethif @@ -87,8 +84,8 @@ let echo_request () = let seq_no = 0x01 in let id_no = 0x1234 in let request_payload = Cstruct.of_string "plz reply i'm so lonely" in - get_stack () >>= configure speaker_address >>= fun speaker -> - get_stack ~backend:speaker.backend () >>= configure listener_address >>= fun listener -> + get_stack speaker_address >>= fun speaker -> + get_stack ~backend:speaker.backend listener_address >>= fun listener -> inform_arp speaker listener_address (mac_of_stack listener); inform_arp listener speaker_address (mac_of_stack speaker); let req = Icmpv4_packet.({code = 0x00; ty = Icmpv4_wire.Echo_request; @@ -119,8 +116,8 @@ let echo_request () = let echo_silent () = let open Icmpv4_packet in - get_stack () >>= configure speaker_address >>= fun speaker -> - get_stack ~backend:speaker.backend () >>= configure listener_address >>= fun listener -> + get_stack speaker_address >>= fun speaker -> + get_stack ~backend:speaker.backend listener_address >>= fun listener -> let req = ({code = 0x00; ty = Icmpv4_wire.Echo_request; subheader = Id_and_seq (0xff, 0x4341)}) in let echo_request = Marshal.make_cstruct req ~payload:Cstruct.(create 0) in @@ -205,8 +202,8 @@ let write_errors () = Alcotest.fail "writing thread completed first"; ] in - get_stack () >>= configure speaker_address >>= fun speaker -> - get_stack ~backend:speaker.backend () >>= configure listener_address >>= fun listener -> + get_stack speaker_address >>= fun speaker -> + get_stack ~backend:speaker.backend listener_address >>= fun listener -> inform_arp speaker listener_address (mac_of_stack listener); inform_arp listener speaker_address (mac_of_stack speaker); Lwt.pick [ diff --git a/lib_test/test_iperf.ml b/lib_test/test_iperf.ml index 092ede0b6..db9344812 100644 --- a/lib_test/test_iperf.ml +++ b/lib_test/test_iperf.ml @@ -26,8 +26,8 @@ module Test_iperf (B : Vnetif_backends.Backend) = struct let backend = V.create_backend () - let netmask = Ipaddr.V4.of_string_exn "255.255.255.0" - let gw = Ipaddr.V4.of_string_exn "10.0.0.1" + let netmask = 24 + let gw = Some (Ipaddr.V4.of_string_exn "10.0.0.1") let client_ip = Ipaddr.V4.of_string_exn "10.0.0.101" let server_ip = Ipaddr.V4.of_string_exn "10.0.0.100" @@ -175,17 +175,19 @@ module Test_iperf (B : Vnetif_backends.Backend) = struct (Lwt_unix.sleep timeout >>= fun () -> (* timeout *) fail "iperf test timed out after %f seconds" timeout); + (server_ready >>= fun () -> Lwt_unix.sleep 0.1 >>= fun () -> (* Give server 0.1 s to call listen *) Logs.info (fun f -> f "I am client with IP %s, trying to connect to server @ %s:%d" (Ipaddr.V4.to_string client_ip) (Ipaddr.V4.to_string server_ip) port); - V.create_stack backend client_ip netmask [gw] >>= fun client_s -> + V.create_stack backend client_ip netmask gw >>= fun client_s -> + Lwt.async (fun () -> V.Stackv4.listen client_s); iperfclient client_s amt server_ip port); (Logs.info (fun f -> f "I am server with IP %s, expecting connections on port %d" (Ipaddr.V4.to_string server_ip) port); - V.create_stack backend server_ip netmask [gw] >>= fun server_s -> + V.create_stack backend server_ip netmask gw >>= fun server_s -> Mclock.connect () >>= fun clock -> V.Stackv4.listen_tcpv4 server_s ~port (iperf clock server_s server_done_u); Lwt.wakeup server_ready_u (); diff --git a/lib_test/test_rfc5961.ml b/lib_test/test_rfc5961.ml index a05d4e95f..0aa0172d0 100644 --- a/lib_test/test_rfc5961.ml +++ b/lib_test/test_rfc5961.ml @@ -28,31 +28,31 @@ module Time = Vnetif_common.Time module V = Vnetif.Make(Vnetif_backends.Basic) module E = Ethif.Make(V) module A = Arpv4.Make(E)(Vnetif_common.Clock)(Time) -module I = Ipv4.Make(E)(A) +module I = Static_ipv4.Make(E)(A) module Wire = Tcp.Wire module WIRE = Wire.Make(I) module Tcp_wire = Tcp.Tcp_wire module Tcp_unmarshal = Tcp.Tcp_packet.Unmarshal module Sequence = Tcp.Sequence -let netmask = Ipaddr.V4.of_string_exn "255.255.255.0" -let gw = Ipaddr.V4.of_string_exn "10.0.0.1" let sut_ip = Ipaddr.V4.of_string_exn "10.0.0.101" let server_ip = Ipaddr.V4.of_string_exn "10.0.0.100" +let netmask = 24 +let gateway = Some (Ipaddr.V4.of_string_exn "10.0.0.1") (* defaults when injecting packets *) let options = [] let window = 5120 let create_sut_stack backend = - VNETIF_STACK.create_stack backend sut_ip netmask [gw] + VNETIF_STACK.create_stack backend sut_ip netmask gateway -let create_raw_stack backend = +let create_raw_stack ip backend = Mclock.connect () >>= fun clock -> V.connect backend >>= fun netif -> E.connect netif >>= fun ethif -> A.connect ethif clock >>= fun arpv4 -> - I.connect ethif arpv4 >>= fun ip -> + I.connect ~ip ~network:(Ipaddr.V4.Prefix.make netmask ip) ~gateway ethif arpv4 >>= fun ip -> Lwt.return (netif, ethif, arpv4, ip) type 'state fsm_result = @@ -66,11 +66,11 @@ type 'state fsm_result = let run backend fsm sut () = let initial_state, fsm_handler = fsm in create_sut_stack backend >>= fun stackv4 -> - create_raw_stack backend >>= fun (netif, ethif, arp, rawip) -> - I.set_ip_netmask rawip netmask >>= fun () -> - I.set_ip rawip server_ip >>= fun () -> + create_raw_stack server_ip backend >>= fun (netif, ethif, arp, rawip) -> let error_mbox = Lwt_mvar.create_empty () in let stream, pushf = Lwt_stream.create () in + Lwt.pick [ + VNETIF_STACK.Stackv4.listen stackv4; (* Consume TCP packets one by one, in sequence *) let rec fsm_thread state = @@ -123,6 +123,7 @@ let run backend fsm sut () = | Some err -> Alcotest.fail err; Lwt.return_unit + ] (* Helper functions *) diff --git a/lib_test/test_socket.ml b/lib_test/test_socket.ml index 53b07daab..b01c22d75 100644 --- a/lib_test/test_socket.ml +++ b/lib_test/test_socket.ml @@ -26,7 +26,6 @@ let make_stack ~name ~ip = let config = { name; interface = [ip]; - mode = (); } in Icmpv4_socket.connect () >>= fun icmp -> Stack.connect config udp tcp >>= fun stack -> diff --git a/lib_test/test_udp.ml b/lib_test/test_udp.ml index d371c9b0a..dc9054be0 100644 --- a/lib_test/test_udp.ml +++ b/lib_test/test_udp.ml @@ -5,7 +5,7 @@ module B = Basic_backend.Make module V = Vnetif.Make(B) module E = Ethif.Make(V) module Static_arp = Static_arp.Make(E)(Mclock)(Time) -module Ip = Ipv4.Make(E)(Static_arp) +module Ip = Static_ipv4.Make(E)(Static_arp) module Udp = Udp.Make(Ip) type stack = { @@ -19,24 +19,18 @@ type stack = { } let get_stack ?(backend = B.create ~use_async_readers:true - ~yield:(fun() -> Lwt_main.yield ()) ()) () = + ~yield:(fun() -> Lwt_main.yield ()) ()) ip = let open Lwt.Infix in + let network = Ipaddr.V4.Prefix.make 24 ip in + let gateway = None in Mclock.connect () >>= fun clock -> V.connect backend >>= fun netif -> E.connect netif >>= fun ethif -> Static_arp.connect ethif clock >>= fun arp -> - Ip.connect ethif arp >>= fun ip -> + Ip.connect ~ip ~network ~gateway ethif arp >>= fun ip -> Udp.connect ip >>= fun udp -> Lwt.return { clock; backend; netif; ethif; arp; ip; udp } -(* assume a class C network with no default gateway *) -let configure ip stack = - let open Lwt.Infix in - Ip.set_ip stack.ip ip >>= fun () -> - Ip.set_ip_netmask stack.ip (Ipaddr.V4.of_string_exn "255.255.255.0") >>= fun - () -> - Lwt.return stack - let fails msg f args = match f args with | Ok _ -> Alcotest.fail msg @@ -62,7 +56,7 @@ let marshal_unmarshal () = let write () = let open Lwt.Infix in let dst = Ipaddr.V4.of_string_exn "192.168.4.20" in - get_stack () >>= configure (Ipaddr.V4.of_string_exn "192.168.4.20") >>= fun stack -> + get_stack dst >>= fun stack -> Static_arp.add_entry stack.arp dst (Macaddr.of_string_exn "00:16:3e:ab:cd:ef"); Udp.write ~src_port:1212 ~dst_port:21 ~dst stack.udp (Cstruct.of_string "MGET *") >>= fun () -> Lwt.return_unit diff --git a/lib_test/vnetif_common.ml b/lib_test/vnetif_common.ml index 724e5084b..323e6523f 100644 --- a/lib_test/vnetif_common.ml +++ b/lib_test/vnetif_common.ml @@ -35,7 +35,7 @@ sig (** Create a new backend *) val create_backend : unit -> backend (** Create a new stack connected to an existing backend *) - val create_stack : backend -> Ipaddr.V4.t -> Ipaddr.V4.t -> Ipaddr.V4.t list -> Stackv4.t Lwt.t + val create_stack : backend -> Ipaddr.V4.t -> int -> Ipaddr.V4.t option -> Stackv4.t Lwt.t (** Add a listener function to the backend *) val create_backend_listener : backend -> (buffer -> unit io) -> id (** Disable a listener function *) @@ -53,7 +53,7 @@ module VNETIF_STACK ( B : Vnetif_backends.Backend) : (VNETIF_STACK with type bac module V = Vnetif.Make(B) module E = Ethif.Make(V) module A = Arpv4.Make(E)(Clock)(Time) - module Ip = Ipv4.Make(E)(A) + module Ip = Static_ipv4.Make(E)(A) module Icmp = Icmpv4.Make(Ip) module U = Udp.Make(Ip) module T = Tcp.Flow.Make(Ip)(Time)(Clock)(Stdlibrandom) @@ -64,18 +64,18 @@ module VNETIF_STACK ( B : Vnetif_backends.Backend) : (VNETIF_STACK with type bac B.create () let create_stack backend ip netmask gw = + let network = Ipaddr.V4.Prefix.make netmask ip in Clock.connect () >>= fun clock -> V.connect backend >>= fun netif -> E.connect netif >>= fun ethif -> A.connect ethif clock >>= fun arpv4 -> - Ip.connect ethif arpv4 >>= fun ipv4 -> + Ip.connect ~ip ~network ~gateway:gw ethif arpv4 >>= fun ipv4 -> Icmp.connect ipv4 >>= fun icmpv4 -> U.connect ipv4 >>= fun udpv4 -> T.connect ipv4 clock >>= fun tcpv4 -> let config = { V1_LWT.name = "stack"; interface = netif; - mode = `IPv4 (ip, netmask, gw); } in Stackv4.connect config ethif arpv4 ipv4 icmpv4 udpv4 tcpv4 diff --git a/myocamlbuild.ml b/myocamlbuild.ml index 4ce69295a..67b91ef3c 100644 --- a/myocamlbuild.ml +++ b/myocamlbuild.ml @@ -1,5 +1,5 @@ (* OASIS_START *) -(* DO NOT EDIT (digest: f498c88068b583064c148b5b42bec20d) *) +(* DO NOT EDIT (digest: 3338242eb0462c3620e512c1a32be731) *) module OASISGettext = struct (* # 22 "src/oasis/OASISGettext.ml" *) @@ -893,7 +893,6 @@ let package_default = ("icmpv4", ["lib/icmp"], []); ("udp", ["lib/udp"], []); ("tcp", ["lib/tcp"], []); - ("dhcpv4", ["lib/dhcp"], []); ("tcpip-stack-direct", ["lib"], []); ("icmpv4-socket", ["unix"], []); ("udpv4-socket", ["unix"], []); @@ -937,9 +936,7 @@ let package_default = ("lib/ipv6", ["lib"; "lib/ethif"]); ("lib/ipv4", ["lib"; "lib/ethif"]); ("lib/icmp", ["lib"]); - ("lib/dhcp", ["lib/udp"]); - ("lib/arpv4", ["lib/ethif"]); - ("lib", ["lib/dhcp"]) + ("lib/arpv4", ["lib/ethif"]) ] } ;; @@ -948,7 +945,7 @@ let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; -# 952 "myocamlbuild.ml" +# 949 "myocamlbuild.ml" (* OASIS_STOP *) Ocamlbuild_plugin.dispatch dispatch_default;; (* Ocamlbuild_pack.Flags.mark_tag_used "tests";; *) diff --git a/setup.ml b/setup.ml index bd0d09882..109be9ff8 100644 --- a/setup.ml +++ b/setup.ml @@ -1,7 +1,7 @@ (* setup.ml generated for the first time by OASIS v0.4.5 *) (* OASIS_START *) -(* DO NOT EDIT (digest: d01479740b6a1de90dfae938c094f561) *) +(* DO NOT EDIT (digest: 3fbc17377d19ba56146ca7fa69e7f4ec) *) (* Regenerated by OASIS v0.4.7 Visit http://oasis.forge.ocamlcore.org for more information and @@ -7827,9 +7827,10 @@ let setup_t = bs_nativeopt = [(OASISExpr.EBool true, [])] }, { - lib_modules = ["Ipv4"; "Ipv4_wire"; "Ipv4_packet"]; + lib_modules = + ["Static_ipv4"; "Ipv4_wire"; "Ipv4_packet"]; lib_pack = false; - lib_internal_modules = []; + lib_internal_modules = ["Ipv4_common"; "Routing"]; lib_findlib_parent = Some "tcpip"; lib_findlib_name = Some "ipv4"; lib_findlib_directory = None; @@ -8470,160 +8471,6 @@ let setup_t = lib_findlib_directory = None; lib_findlib_containers = [] }); - Library - ({ - cs_name = "dhcpv4"; - cs_data = PropList.Data.create (); - cs_plugin_data = [] - }, - { - bs_build = [(OASISExpr.EBool true, true)]; - bs_install = [(OASISExpr.EBool true, true)]; - bs_path = "lib/dhcp"; - bs_compiled_object = Best; - bs_build_depends = - [ - FindlibPackage ("logs", None); - FindlibPackage ("io-page", None); - FindlibPackage ("mirage-types", None); - FindlibPackage ("ipaddr", None); - FindlibPackage ("cstruct", None); - FindlibPackage ("cstruct.ppx", None); - FindlibPackage ("lwt", None); - InternalLibrary "udp"; - FindlibPackage ("duration", None); - FindlibPackage ("randomconv", None) - ]; - bs_build_tools = [ExternalTool "ocamlbuild"]; - bs_interface_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${capitalize_file module}.mli" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mli" - ]; - origin = "${uncapitalize_file module}.mli" - } - ]; - bs_implementation_patterns = - [ - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${capitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".ml" - ]; - origin = "${uncapitalize_file module}.ml" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${capitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mll" - ]; - origin = "${uncapitalize_file module}.mll" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("capitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${capitalize_file module}.mly" - }; - { - OASISSourcePatterns.Templater.atoms = - [ - OASISSourcePatterns.Templater.Text ""; - OASISSourcePatterns.Templater.Expr - (OASISSourcePatterns.Templater.Call - ("uncapitalize_file", - OASISSourcePatterns.Templater.Ident - "module")); - OASISSourcePatterns.Templater.Text ".mly" - ]; - origin = "${uncapitalize_file module}.mly" - } - ]; - bs_c_sources = []; - bs_data_files = []; - bs_findlib_extra_files = []; - bs_ccopt = [(OASISExpr.EBool true, [])]; - bs_cclib = [(OASISExpr.EBool true, [])]; - bs_dlllib = [(OASISExpr.EBool true, [])]; - bs_dllpath = [(OASISExpr.EBool true, [])]; - bs_byteopt = [(OASISExpr.EBool true, [])]; - bs_nativeopt = [(OASISExpr.EBool true, [])] - }, - { - lib_modules = ["Dhcpv4_option"; "Dhcp_clientv4"]; - lib_pack = false; - lib_internal_modules = []; - lib_findlib_parent = Some "tcpip"; - lib_findlib_name = Some "dhcpv4"; - lib_findlib_directory = None; - lib_findlib_containers = [] - }); Library ({ cs_name = "tcpip-stack-direct"; @@ -8641,7 +8488,6 @@ let setup_t = FindlibPackage ("mirage-types", None); FindlibPackage ("ipaddr", None); FindlibPackage ("lwt", None); - InternalLibrary "dhcpv4"; FindlibPackage ("result", None) ]; bs_build_tools = [ExternalTool "ocamlbuild"]; @@ -9905,7 +9751,7 @@ let setup_t = }; oasis_fn = Some "_oasis"; oasis_version = "0.4.7"; - oasis_digest = Some "Jf\243\015M&\162R>\239\155\251\134\135\165?"; + oasis_digest = Some "\243\150\141}\237\141\1801\241\149\211T\146\148&x"; oasis_exec = None; oasis_setup_args = []; setup_update = false @@ -9913,7 +9759,7 @@ let setup_t = let setup () = BaseSetup.setup setup_t;; -# 9917 "setup.ml" +# 9763 "setup.ml" let setup_t = BaseCompat.Compat_0_4.adapt_setup_t setup_t open BaseCompat.Compat_0_4 (* OASIS_STOP *) diff --git a/unix/tcpip_stack_socket.ml b/unix/tcpip_stack_socket.ml index 5384c4013..676305459 100644 --- a/unix/tcpip_stack_socket.ml +++ b/unix/tcpip_stack_socket.ml @@ -33,10 +33,9 @@ module Tcpv4 = Tcpv4_socket module Udpv4 = Udpv4_socket type +'a io = 'a Lwt.t -type ('a,'b) config = ('a,'b) V1_LWT.stackv4_config +type 'a config = 'a V1_LWT.stackv4_config type netif = Ipaddr.V4.t list -type mode = unit -type id = (netif, mode) config +type id = netif config type buffer = Cstruct.t type ipv4addr = Ipaddr.V4.t diff --git a/unix/tcpip_stack_socket.mli b/unix/tcpip_stack_socket.mli index 9d0138b49..f08929540 100644 --- a/unix/tcpip_stack_socket.mli +++ b/unix/tcpip_stack_socket.mli @@ -16,12 +16,11 @@ include V1_LWT.STACKV4 with type netif = Ipaddr.V4.t list - and type mode = unit and type tcpv4 = Tcpv4_socket.t and type udpv4 = Udpv4_socket.t and type ipv4 = Ipaddr.V4.t option and module UDPV4 = Udpv4_socket and module TCPV4 = Tcpv4_socket and module IPV4 = Ipv4_socket -val connect : (netif, mode) V1_LWT.stackv4_config -> +val connect : netif V1_LWT.stackv4_config -> Udpv4_socket.t -> Tcpv4_socket.t -> t Lwt.t