Commits

Anonymous committed 79212b0

Alan Post provided this test, which is a very crude TCP echo program. It
helped find a very bad stack leak in Cf_gadget.

  • Participants
  • Parent commits 8a9862f

Comments (0)

Files changed (1)

File iom/t/t_echo.ml

+(*---------------------------------------------------------------------------*
+  PROGRAM  t_echo.ml
+
+  Copyright (c) 2003-2004, James H. Woodyatt
+  All rights reserved.
+
+  Redistribution and use in source and binary forms, with or without
+  modification, are permitted provided that the following conditions
+  are met:
+
+    Redistributions of source code must retain the above copyright
+    notice, this list of conditions and the following disclaimer.
+
+    Redistributions in binary form must reproduce the above copyright
+    notice, this list of conditions and the following disclaimer in
+    the documentation and/or other materials provided with the
+    distribution
+
+  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+  OF THE POSSIBILITY OF SUCH DAMAGE. 
+ *---------------------------------------------------------------------------*)
+
+let jout = Cf_journal.stdout
+
+module G = Iom_gadget
+module R = Iom_reactor
+open Cf_cmonad.Op
+
+module SR = Iom_sock_stream
+module TCP_s = Cf_tcp4_socket
+module TCP_r = Iom_tcp4_socket
+let any_address = Cf_ip4_addr.any;;
+
+type echoer_state_t = Ready | Blocked
+
+let count = ref 0
+
+let echoer_ socket k =
+  G.duplex >>= fun ((er, et), c) ->
+  TCP_r.endpoint ~c socket k >>= fun () ->
+  let er = (er :> SR.endpoint_rx_t G.rx) in
+  let et = (et :> SR.endpoint_tx_t G.tx) in
+  let window = 1 in
+  let extendM n =
+    et#put (SR.IO_tx_extend n)
+  in
+  G.start (extendM window) Ready >>= fun () ->
+  let rec loop () =
+    G.guard begin
+      er#get begin function
+      | SR.IO_rx_data m ->
+        let len = Cf_message.length m in
+        count := !count + len;
+        Printf.printf "Received a total of %d bytes\n" !count;
+        flush stdout;
+        (extendM (Cf_message.length m)) >>= fun () ->
+        et#put (SR.IO_tx_data m) >>= loop
+      | SR.IO_rx_error _
+      | SR.IO_rx_closed -> Cf_cmonad.return ()
+      | SR.IO_rx_unlinked -> loop ()
+      | SR.IO_rx_release -> et#put (SR.IO_tx_release) >>= loop
+      | SR.IO_rx_ready ->
+        extendM window >>= fun () ->
+        G.store Ready >>= loop
+      | SR.IO_rx_blocked -> 
+        print_string "Blocked\n";
+        print_string "Blocked\n";
+        print_string "Blocked\n";
+        flush stdout;
+        G.load >>= begin function
+        | Blocked -> failwith "Got a blocked message when already blocked"
+        | Ready -> (extendM (-window)) >>= fun () ->
+                   G.store Blocked >>= loop
+        end
+      end
+    end
+  in
+  G.start (loop ()) Ready
+
+let listener_ k =
+  let address = (any_address, 24024 :> TCP_s.address_t) in
+  G.duplex >>= fun ((lr, lt), c) ->
+  TCP_r.listener ~c address k >>= fun () ->
+  let lr = (lr :> TCP_r.listener_rx_t G.rx) in
+  let lt = (lt :> TCP_r.listener_tx_t G.tx) in
+  let initM =
+    lt#put (TCP_r.L_limit 2000)
+  in
+  G.start initM () >>= fun () ->
+  let rec loop () =
+    G.guard begin
+      lr#get begin function
+      | TCP_r.L_error _ -> failwith "Listen error"
+      | TCP_r.L_connect (socket, _, _) -> echoer_ socket k >>= loop
+      | TCP_r.L_bind _ -> loop ()
+      end
+    end
+  in
+  G.start (loop ()) ()
+
+let () =
+    try G.run listener_ () with
+    | Unix.Unix_error (error, where, arg) ->
+        let error = Unix.error_message error in
+        jout#error "Unix error: '%s' in %s(%s)\n" error where arg
+
+(*--- End of Program [ t_mirrord.ml ] ---*)