diff --git a/mirage/utcp_mirage.ml b/mirage/utcp_mirage.ml index d0ff755..0b75d59 100644 --- a/mirage/utcp_mirage.ml +++ b/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 diff --git a/src/user.ml b/src/user.ml index 0eeb888..21b70b0 100644 --- a/src/user.ml +++ b/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 diff --git a/src/utcp.ml b/src/utcp.ml index 8645def..5e6641b 100644 --- a/src/utcp.ml +++ b/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 diff --git a/src/utcp.mli b/src/utcp.mli index 33d2204..c378a66 100644 --- a/src/utcp.mli +++ b/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