Merge pull request mirage#142 from samoht/debug

Debug

.merlin

@@ -1,4 +1,6 @@
-PKG lwt ipaddr lwt mirage-types cstruct io-page uint mirage-flow oUnit alcotest mirage-vnetif pcap-format
+PKG lwt ipaddr lwt mirage-types cstruct io-page uint mirage-flow oUnit alcotest
+PKG mirage-vnetif pcap-format mirage-console.unix
+
 B _build/**
 S lib/
 S tcp/

_oasis

@@ -71,7 +71,8 @@ Library tcp
   Findlibparent:      tcpip
   Findlibname:        tcp
   Modules:            Options,Wire,State,Tcptimer,Sequence,Ack,
-                      Window,Segment,User_buffer,Pcb,Flow
+                      Window,Segment,User_buffer,Pcb,Flow,
+                      Stats, Log
   BuildDepends:       io-page,
                       mirage-types,
                       ipaddr,
@@ -311,4 +312,4 @@ Executable test
 
 Test test
   Run$: flag(tests)
-  Command: $test
+  Command: $test -q

_tags

@@ -1,5 +1,5 @@
 # OASIS_START
-# DO NOT EDIT (digest: 60995254e5001cb612a968dd205139c1)
+# DO NOT EDIT (digest: 20191569a0d28c34718dadfefb87302c)
 # 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
@@ -51,6 +51,8 @@ true: annot, bin_annot
 "tcp/user_buffer.cmx": for-pack(Tcp)
 "tcp/pcb.cmx": for-pack(Tcp)
 "tcp/flow.cmx": for-pack(Tcp)
+"tcp/stats.cmx": for-pack(Tcp)
+"tcp/log.cmx": for-pack(Tcp)
 <tcp/*.ml{,i,y}>: pkg_bytes
 <tcp/*.ml{,i,y}>: pkg_cstruct
 <tcp/*.ml{,i,y}>: pkg_io-page

channel/channel.ml

@@ -16,7 +16,7 @@
 
 (** Buffered reading and writing over the Flow API *)
 
-open Lwt
+open Lwt.Infix
 
 module Make(Flow:V1_LWT.FLOW) = struct
 
@@ -53,20 +53,20 @@ module Make(Flow:V1_LWT.FLOW) = struct
          buffers, this will be violated causing Channel users to see Cstruct
          exceptions *)
       t.ibuf <- Some buf;
-      return_unit
+      Lwt.return_unit
     | `Error e ->
-      fail (Read_error e)
+      Lwt.fail (Read_error e)
     | `Eof ->
       (* close the flow before throwing exception; otherwise it will never be
          GC'd *)
       Flow.close t.flow >>= fun () ->
-      fail End_of_file
+      Lwt.fail End_of_file
 
   let rec get_ibuf t =
     match t.ibuf with
     | None -> ibuf_refill t >>= fun () -> get_ibuf t
     | Some buf when Cstruct.len buf = 0 -> ibuf_refill t >>= fun () -> get_ibuf t
-    | Some buf -> return buf
+    | Some buf -> Lwt.return buf
 
   (* Read one character from the input channel *)
   let read_char t =
@@ -75,7 +75,7 @@ module Make(Flow:V1_LWT.FLOW) = struct
     let c = Cstruct.get_char buf 0 in
     t.ibuf <- Some (Cstruct.shift buf 1); (* advance read buffer, possibly to
                                              EOF *)
-    return c
+    Lwt.return c
 
   (* Read up to len characters from the input channel
      and at most a full view. If not specified, read all *)
@@ -88,21 +88,23 @@ module Make(Flow:V1_LWT.FLOW) = struct
       let hd,tl = Cstruct.split buf len in
       t.ibuf <- Some tl; (* leave some in the buffer; next time, we won't do a
                             blocking read *)
-      return hd
+      Lwt.return hd
     end else begin
       t.ibuf <- None;
-      return buf
+      Lwt.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 () ->
         Lwt.catch
-          (fun () -> read_some ?len t >>= fun v -> return (Some v))
-          (function End_of_file -> return_none | e -> fail e)
+          (fun () -> read_some ?len t >>= fun v -> Lwt.return (Some v))
+          (function End_of_file -> Lwt.return_none | e -> Lwt.fail e)
       )
 
+  let zero = Cstruct.create 0
+
   (* Read until a character is found *)
   let read_until t ch =
     Lwt.catch
@@ -116,12 +118,12 @@ module Make(Flow:V1_LWT.FLOW) = struct
          match scan 0 with
          | None ->                (* not found, return what we have until EOF *)
            t.ibuf <- None;    (* basically guaranteeing that next read is EOF *)
-           return (false, buf)
+           Lwt.return (false, buf)
          | Some off ->                          (* found, so split the buffer *)
            let hd = Cstruct.sub buf 0 off in
            t.ibuf <- Some (Cstruct.shift buf (off+1));
-           return (true, hd))
-      (function End_of_file -> return (false, Cstruct.create 0) | e -> fail e)
+           Lwt.return (true, hd))
+      (function End_of_file -> Lwt.return (false, zero) | e -> Lwt.fail e)
 
   (* 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).
@@ -130,15 +132,15 @@ module Make(Flow:V1_LWT.FLOW) = struct
     let rec get acc =
       read_until t '\n' >>= function
       |(false, v) ->
-        if Cstruct.len v = 0 then return (v :: acc) else get (v :: acc)
+        if Cstruct.len v = 0 then Lwt.return (v :: acc) else 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)
+          Lwt.return (v :: acc)
         end
     in
     get [] >|= List.rev
@@ -208,9 +210,9 @@ module Make(Flow:V1_LWT.FLOW) = struct
     let l = List.rev t.obufq in
     t.obufq <- [];
     Flow.writev t.flow l >>= function
-    | `Ok () -> Lwt.return_unit
-    | `Error e -> fail (Write_error e)
-    | `Eof -> fail End_of_file
+    | `Ok ()   -> Lwt.return_unit
+    | `Error e -> Lwt.fail (Write_error e)
+    | `Eof     -> Lwt.fail End_of_file
 
   let close t =
     Lwt.finalize (fun () -> flush t) (fun () -> Flow.close t.flow)

dhcp/dhcp_clientv4.ml

@@ -15,7 +15,7 @@
  *
  *)
 
-open Lwt
+open Lwt.Infix
 open Printf
 
 module Make (Console : V1_LWT.CONSOLE)
@@ -182,9 +182,9 @@ module Make (Console : V1_LWT.CONSOLE)
           end
         |_ -> Console.log_s t.c "DHCP: ack not for us"
       end
-    | Shutting_down -> return_unit
-    | Lease_held _ -> Console.log_s t.c "DHCP input: lease already held"
-    | Disabled -> Console.log_s t.c "DHCP input: disabled"
+    | Shutting_down -> Lwt.return_unit
+    | Lease_held _  -> Console.log_s t.c "DHCP input: lease already held"
+    | Disabled      -> Console.log_s t.c "DHCP input: disabled"
 
   (* Start a DHCP discovery off on an interface *)
   let start_discovery t =
@@ -201,7 +201,7 @@ module Make (Console : V1_LWT.CONSOLE)
     >>= fun () ->
     t.state <- Request_sent xid;
     output_broadcast t ~xid ~yiaddr ~siaddr ~options >>= fun () ->
-    return_unit
+    Lwt.return_unit
 
   (* DHCP state thred *)
   let rec dhcp_thread t =
@@ -234,7 +234,7 @@ module Make (Console : V1_LWT.CONSOLE)
                          (String.concat ", " (List.map Ipaddr.V4.to_string info.gateways)))
       >>= fun () ->
       offer_push (Some info);
-      return_unit
+      Lwt.return_unit
     in
     let t = { c; mac; udp; state; new_offer } in
     (* TODO cancellation *)

lib/arpv4.ml

@@ -15,7 +15,7 @@
  *
  *)
 
-open Lwt
+open Lwt.Infix
 open Printf
 
 module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = struct
@@ -120,18 +120,18 @@ module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = str
         let spa = Ipaddr.V4.of_int32 (get_arp_tpa frame) in (* the requested address *)
         let tpa = Ipaddr.V4.of_int32 (get_arp_spa frame) in (* the requesting host IPv4 *)
         output t { op=`Reply; sha; tha; spa; tpa }
-      end else return_unit
+      end else Lwt.return_unit
     |2 -> (* Reply *)
       let spa = Ipaddr.V4.of_int32 (get_arp_spa frame) in
       let sha = Macaddr.of_bytes_exn (copy_arp_sha frame) in
       printf "ARP: updating %s -> %s\n%!"
         (Ipaddr.V4.to_string spa) (Macaddr.to_string sha);
       (* If we have pending entry, notify the waiters that answer is ready *)
       notify t spa sha;
-      return_unit
+      Lwt.return_unit
     |n ->
       printf "ARP: Unknown message %d ignored\n%!" n;
-      return_unit
+      Lwt.return_unit
 
   and output t arp =
     (* Obtain a buffer to write into *)
@@ -193,12 +193,12 @@ module Make (Ethif : V1_LWT.ETHIF) (Clock : V1.CLOCK) (Time : V1_LWT.TIME) = str
   let add_ip t ip =
     if not (List.mem ip t.bound_ips) then
       set_ips t (ip :: t.bound_ips)
-    else return_unit
+    else Lwt.return_unit
 
   let remove_ip t ip =
     if List.mem ip t.bound_ips then
       set_ips t (List.filter ((<>) ip) t.bound_ips)
-    else return_unit
+    else Lwt.return_unit
 
   (* Query the cache for an ARP entry, which may result in the sender sleeping
      waiting for a response *)

lib/ethif.ml

@@ -15,7 +15,7 @@
  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  *
  *)
-open Lwt
+open Lwt.Infix
 
 module Make(Netif : V1_LWT.NETWORK) = struct
 
@@ -42,25 +42,23 @@ module Make(Netif : V1_LWT.NETWORK) = struct
     MProf.Trace.label "ethif.input";
     let frame_mac = Macaddr.of_bytes (Wire_structs.copy_ethernet_dst frame) in
     match frame_mac with
-    | None -> return_unit
-    | Some frame_mac -> begin
-        if (((Macaddr.compare frame_mac (mac t)) == 0) || (not (Macaddr.is_unicast frame_mac))) then
-          match Wire_structs.get_ethernet_ethertype frame with
-          | 0x0806 ->
-            arpv4 frame (* ARP *)
-          | 0x0800 -> (* IPv4 *)
-            let payload = Cstruct.shift frame Wire_structs.sizeof_ethernet in
-            ipv4 payload
-          | 0x86dd ->
-            let payload = Cstruct.shift frame Wire_structs.sizeof_ethernet in
-            ipv6 payload
-          | _etype ->
-            let _payload = Cstruct.shift frame Wire_structs.sizeof_ethernet in
-            (* TODO default etype payload *)
-            return_unit
-        else
-          return_unit
-      end
+    | None           -> Lwt.return_unit
+    | Some frame_mac ->
+      if Macaddr.compare frame_mac (mac t) = 0
+         || not (Macaddr.is_unicast frame_mac)
+      then match Wire_structs.get_ethernet_ethertype frame with
+        | 0x0806 -> arpv4 frame (* ARP *)
+        | 0x0800 -> (* IPv4 *)
+          let payload = Cstruct.shift frame Wire_structs.sizeof_ethernet in
+          ipv4 payload
+        | 0x86dd ->
+          let payload = Cstruct.shift frame Wire_structs.sizeof_ethernet in
+          ipv6 payload
+        | _etype ->
+          let _payload = Cstruct.shift frame Wire_structs.sizeof_ethernet in
+          (* TODO default etype payload *)
+          Lwt.return_unit
+      else Lwt.return_unit
 
   let write t frame =
     MProf.Trace.label "ethif.write";
@@ -72,7 +70,7 @@ module Make(Netif : V1_LWT.NETWORK) = struct
 
   let connect netif =
     MProf.Trace.label "ethif.connect";
-    return (`Ok { netif })
+    Lwt.return (`Ok { netif })
 
-  let disconnect _ = return_unit
+  let disconnect _ = Lwt.return_unit
 end