user: implement shutdown; also close/shutdown/send may output a packet

mirage: deal with user changes

mirage/utcp_mirage.ml

@@ -34,11 +34,30 @@ module Make (R : Mirage_random.S) (Mclock : Mirage_clock.MCLOCK) (Time : Mirage_
     let _, (dst, dst_port) = Utcp.peers flow in
     dst, dst_port
 
+  let output_ip t (src, dst, seg) =
+    Ip.write t.ip ~src dst `TCP (fun _ -> 0) [seg]
+
+  let maybe_output_ign t seg =
+    Option.fold
+      ~none:Lwt.return_unit
+      ~some:(fun seg ->
+          output_ip t seg >|= function
+          | Error e ->
+            Log.err (fun m -> m "error sending data: %a" Ip.pp_error e)
+          | Ok () -> ())
+      seg
+
   let close t flow =
-    match Utcp.close t.tcp flow with
-    | Ok tcp -> t.tcp <- tcp
-    | Error `Msg msg -> Log.err (fun m -> m "error in close: %s" msg)
+    match Utcp.close t.tcp (now ()) flow with
+    | Ok (tcp, seg) ->
+      t.tcp <- tcp ;
+      maybe_output_ign t seg
+    | Error `Msg msg ->
+      Log.err (fun m -> m "error in close: %s" msg);
+      Lwt.return_unit
 
+  (* there's an issue with draining on close... so recv returns eof, but
+     there was stuff in rcvq that has been dropped *)
   let rec read (t, flow) =
     match Utcp.recv t.tcp flow with
     | Ok (tcp, data) ->
@@ -52,31 +71,33 @@ module Make (R : Mirage_random.S) (Mclock : Mirage_clock.MCLOCK) (Time : Mirage_
       else
         Lwt.return (Ok (`Data data))
     | Error `Msg msg ->
-      close t flow;
+      close t flow >>= fun () ->
       Log.err (fun m -> m "error while read %s" msg);
       (* TODO better error *)
       Lwt.return (Error `Refused)
 
   let write (t, flow) buf =
-    match Utcp.send t.tcp flow buf with
-    | Ok tcp -> t.tcp <- tcp ; Lwt.return (Ok ())
+    match Utcp.send t.tcp (now ()) flow buf with
+    | Ok (tcp, seg) ->
+      t.tcp <- tcp ;
+      maybe_output_ign t seg >|= fun () ->
+      Ok ()
     | Error `Msg msg ->
-      close t flow;
+      close t flow >>= fun () ->
       Log.err (fun m -> m "error while write %s" msg);
       (* TODO better error *)
       Lwt.return (Error `Refused)
 
   let writev flow bufs = write flow (Cstruct.concat bufs)
 
-  let close (t, flow) = close t flow ; Lwt.return_unit
+  let close (t, flow) =
+    (* TODO at some point, in FM the condition must be signalled *)
+    close t flow
 
   let write_nodelay flow buf = write flow buf
 
   let writev_nodelay flow bufs = write flow (Cstruct.concat bufs)
 
-  let output_ip t (src, dst, seg) =
-    Ip.write t.ip ~src dst `TCP (fun _ -> 0) [seg]
-
   let create_connection ?keepalive:_ t (dst, dst_port) =
     let src = Ip.src t.ip ~dst in
     let tcp, id, seg = Utcp.connect ~src ~dst ~dst_port t.tcp (now ()) in

src/user.ml

@@ -44,16 +44,37 @@ let connect ~src ?src_port ~dst ~dst_port t now =
   in
   { t with connections }, id, (src, dst, data)
 
-(* it occurs that all these functions below are not well suited for sending out
-   segments, a tcp_output(_really) will for sure help *)
-
-(* or should only a timer be responsible for outputting data? sounds a bit weird *)
+(* shutdown_1 and shutdown_3 *)
+let shutdown t now id v =
+  match CM.find_opt id t.connections with
+  | None -> Error (`Msg "no connection")
+  | Some conn ->
+    if conn.tcp_state = Established then
+      let write = match v with `write | `read_write -> true | `read -> false
+      and read = match v with `read | `read_write -> true | `write -> false
+      in
+      let cantsndmore = write || conn.cantsndmore
+      and cantrcvmore = read || conn.cantrcvmore
+      in
+      let tf_shouldacknow = write in
+      let rcvq = if read then Cstruct.empty else conn.rcvq in
+      let control_block = { conn.control_block with tf_shouldacknow } in
+      let conn' =
+        { conn with control_block; cantsndmore; cantrcvmore; rcvq }
+      in
+      let conn', out = Segment.tcp_output_perhaps now id conn' in
+      let out = Option.map (fun (src, dst, seg) -> src, dst, Segment.encode_and_checksum ~src ~dst seg) out in
+      Ok ({ t with connections = CM.add id conn' t.connections }, out)
+    else
+      Error (`Msg "not connected")
 
 (* in real, this is shutdown `readwrite (close_2) - and we do this in any state *)
-let close t id =
+(* there's as well close_3 (the abortive close, i.e. send a RST) -- done when SO_LINGER = 0 *)
+let close t now id =
   match CM.find_opt id t.connections with
   | None -> Error (`Msg "no connection")
   | Some conn ->
+    (* see above, should deal with all states of conn *)
     let* () =
       guard (behind_established conn.tcp_state) (`Msg "not yet established")
     in
@@ -62,9 +83,11 @@ let close t id =
       let cantsndmore = true and cantrcvmore = true and rcvq = Cstruct.empty in
       { conn with control_block; cantsndmore; cantrcvmore; rcvq }
     in
-    Ok { t with connections = CM.add id conn' t.connections }
+    let conn', out = Segment.tcp_output_perhaps now id conn' in
+    let out = Option.map (fun (src, dst, seg) -> src, dst, Segment.encode_and_checksum ~src ~dst seg) out in
+    Ok ({ t with connections = CM.add id conn' t.connections }, out)
 
-let send t id buf =
+let send t now id buf =
   match CM.find_opt id t.connections with
   | None -> Error (`Msg "no connection")
   | Some conn ->
@@ -74,9 +97,12 @@ let send t id buf =
     let* () =
       guard (not conn.cantsndmore) (`Msg "cant write")
     in
+    (* TODO sndq should have a size limit (and if exceeded, return an error) *)
     let sndq = Cstruct.append conn.sndq buf in
     let conn' = { conn with sndq } in
-    Ok { t with connections = CM.add id conn' t.connections }
+    let conn', out = Segment.tcp_output_perhaps now id conn' in
+    let out = Option.map (fun (src, dst, seg) -> src, dst, Segment.encode_and_checksum ~src ~dst seg) out in
+    Ok ({ t with connections = CM.add id conn' t.connections }, out)
 
 let recv t id =
   match CM.find_opt id t.connections with

src/utcp.ml

@@ -25,6 +25,8 @@ let connect = User.connect
 
 let close = User.close
 
+let shutdown = User.shutdown
+
 let recv = User.recv
 
 let send = User.send

src/utcp.mli

@@ -25,11 +25,16 @@ val handle_buf : state -> Mtime.t -> src:Ipaddr.t -> dst:Ipaddr.t ->
 val connect : src:Ipaddr.t -> ?src_port:int -> dst:Ipaddr.t -> dst_port:int ->
   state -> Mtime.t -> (state * flow * output)
 
-val close : state -> flow -> (state, [ `Msg of string ]) result
+val close : state -> Mtime.t -> flow ->
+  (state * output option, [ `Msg of string ]) result
+
+val shutdown : state -> Mtime.t -> flow -> [ `read | `write | `read_write ] ->
+  (state * output option, [ `Msg of string ]) result
 
 val recv : state -> flow -> (state * Cstruct.t, [ `Msg of string ]) result
 
-val send : state -> flow -> Cstruct.t -> (state, [ `Msg of string ]) result
+val send : state -> Mtime.t -> flow -> Cstruct.t ->
+  (state * output option, [ `Msg of string ]) result
 
 module Sequence : sig
   type t