Add Server.close, fix close message semantics (#79)

reynir · web-flow · commit 95e469cacd00 · 2025-05-15T12:55:02.000+02:00
When receiving a SSH_MSG_CHANNEL_CLOSE message you are supposed to send
back a SSH_MSG_CHANNEL_CLOSE **unless** you already sent one.
diff --git a/lib/client.ml b/lib/client.ml
@@ -477,10 +477,15 @@ let input_msg t msg now =
     let* c = guard_some (Channel.lookup id t.channels) "no such channel" in
     let channels = Channel.remove (Channel.id c) t.channels in
     let msg = "all the channels are closed now, nothing left to do here" in
-    Ok ({ t with channels },
+    let msgs =
+      match c.state with
+      | Open ->
         [ Msg_channel_close (Channel.id c) ;
-          Msg_disconnect (DISCONNECT_BY_APPLICATION, msg, "") ],
-        [ `Disconnected ])
+          Msg_disconnect (DISCONNECT_BY_APPLICATION, msg, "") ]
+      | Sent_close ->
+        [ Msg_disconnect (DISCONNECT_BY_APPLICATION, msg, "") ]
+    in
+    Ok ({ t with channels }, msgs, [ `Disconnected ])
   | _, Msg_disconnect (code, msg, lang) ->
     Log.err (fun m -> m "disconnected: %s %s%s"
                 (Ssh.disconnect_code_to_string code)
@@ -541,7 +546,10 @@ let close ?(id = 0l) t =
     let* () = guard (established t) "not yet established" in
     let* c = guard_some (Channel.lookup id t.channels) "no such channel" in
     let msg = Ssh.Msg_channel_close c.them.id in
-    Ok (output_msg t msg)
+    let t, msg = output_msg t msg in
+    let c = { c with state = Sent_close } in
+    let t = { t with channels = Channel.update c t.channels } in
+    Ok (t, msg)
   with
   | Error _ -> t, None
   | Ok (t, msg) -> t, Some msg
diff --git a/lib/server.ml b/lib/server.ml
@@ -552,7 +552,9 @@ let input_msg t msg now =
   | Msg_channel_close recp_channel ->
     let open Channel in
     (match lookup recp_channel t.channels with
-     | None -> make_noreply t        (* XXX or should we disconnect ? *)
+     | None ->
+       Log.warn (fun m -> m "Unexpected SSH_MSG_CHANNEL_CLOSE %lu" recp_channel);
+       make_noreply t        (* XXX or should we disconnect ? *)
      | Some c ->
        let t = { t with channels = remove recp_channel t.channels } in
        (match c.state with
@@ -602,3 +604,16 @@ let output_channel_data t id data =
   let* c = guard_some (Channel.lookup id t.channels) "no such channel" in
   let* c, frags = Channel.output_data ~flush:false c data in
   Ok ({ t with channels = Channel.update c t.channels }, frags)
+
+let close t id =
+  match
+    let* c = guard_some (Channel.lookup id t.channels) "no such channel" in
+    let msg = Ssh.Msg_channel_close c.them.id in
+    (* XXX: when can [output_msg] fail? what do we do then? *)
+    let* t, msg = output_msg t msg in
+    let c = { c with state = Sent_close } in
+    let t = { t with channels = Channel.update c t.channels } in
+    Ok (t, msg)
+  with
+  | Error _ -> t, None
+  | Ok (t, msg) -> t, Some msg
