Commits

Anonymous committed 6ab0559

Removing obsolete tests.

  • Participants
  • Parent commits 030d226

Comments (0)

Files changed (3)

File iom/t/t_echo.ml

-(*---------------------------------------------------------------------------*
-  PROGRAM  t_echo.ml
-
-  Copyright (c) 2003-2005, 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 ] ---*)

File iom/t/t_mirrorc.ml

-(*---------------------------------------------------------------------------*
-  PROGRAM  t_mirrorc.ml
-
-  Copyright (c) 2004-2005, 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
-let _ = jout#setlimit `None
-
-module G = Iom_gadget
-module SR = Iom_sock_stream
-
-open Cf_cmonad.Op
-
-module type Discipline_T = sig
-    val create:
-        SR.endpoint_rx_t #G.rx -> SR.endpoint_rx_t #G.tx -> ('s, unit) G.t
-end
-
-module Discipline: Discipline_T = struct
-    let search_crlf_ =
-        let rec loop n s =
-            match Lazy.force s with
-            | Cf_seq.P ('\r', tl) ->
-                let n = succ n in begin
-                    match Lazy.force tl with
-                    | Cf_seq.P ('\n', _) ->
-                        succ n
-                    | s ->
-                        loop n tl
-                end
-            | Cf_seq.P (_, tl) ->
-                loop (succ n) tl
-            | Cf_seq.Z ->
-                0
-        in
-        fun m ->
-            let s = Cf_message.to_seq m in
-            let pos = loop 0 s in
-            Cf_message.split ~pos m
-
-    module SC = Cf_scmonad
-
-    module type SM = sig
-        type ('s, 'i, 'o, 'a) t = ('s, ('i, 'o) Cf_flow.t, 'a) SC.t
-
-        val read: ('s, 'i, 'o, 'i) t
-        val write: 'o -> ('s, 'i, 'o, unit) t
-        val finish: ('s, 'i, 'o, unit) t
-    end
-
-    module SM: SM = struct
-        type ('s, 'i, 'o, 'a) t = ('s, ('i, 'o) Cf_flow.t, 'a) SC.t
-
-        let read f w = lazy (Cf_flow.Q (fun a -> Lazy.force (f a w)))
-        let write o a b = SC.cont (fun w -> lazy (Cf_flow.P (o, w))) a b
-        let finish a b = SC.init (Lazy.lazy_from_val Cf_flow.Z) a b
-    end
-
-    module C = Cf_cmonad
-    open SC.Op
-
-    let create =
-        let rec loop () =
-            SM.read >>= function
-            | (SR.IO_rx_release | SR.IO_rx_closed as event) ->
-                SC.load >>= begin function
-                | [] ->
-                    SM.write event >>= fun () ->
-                    SM.finish
-                | msg ->
-                    SM.write (SR.IO_rx_data msg) >>= fun () ->
-                    SM.write event >>= fun () ->
-                    SM.finish
-                end
-            | SR.IO_rx_data m1 ->
-                SC.load >>= begin fun m0 ->
-                let m0, m1 = search_crlf_ (m0 @ m1) in
-                match m0 with
-                | [] ->
-                    SC.store m1 >>= loop
-                | _ ->
-                    SM.write (SR.IO_rx_data m0) >>= fun () ->
-                    SC.store m1 >>= loop
-                end
-            | event ->
-                SM.write event
-        in
-        fun rx tx ->
-            let w =
-                let m =
-                    C.Op.( >>= ) (SC.down (loop ()) []) (fun _ -> C.return ())
-                in
-                C.eval m (Lazy.lazy_from_val Cf_flow.Z)
-            in
-            G.wrap rx tx w
-end
-
-module TCP = Cf_tcp4_socket
-
-module Opt = struct
-    open Arg
-    
-    module NI = Cf_nameinfo
-    
-    let host_ = ref "localhost"
-    let port_ = ref None
-    let sessions_ = ref 1
-    let count_ = ref 1
-    
-    let specs_ = Arg.align [
-        "-n", Set_int sessions_, " Number of sessions";
-        "-j", Set_int count_, " Number of messages to send per session";
-        "-h", Set_string host_, " Remote hostname (or IP address)";
-    ]
-    
-    let anon_ p =
-        if !port_ <> None then jout#fail "unexpected anonymous argument";
-        port_ := (Some p)
-    
-    let usage_ =
-        Printf.sprintf "Usage: %s [-n count] [-h host] port"
-            Sys.executable_name
-    
-    let () =
-        parse specs_ anon_ usage_
-    
-    let server =
-        let port =
-            match !port_ with
-            | None ->
-                usage specs_ usage_;
-                jout#fail "remote service is required"
-            | Some p ->
-                p
-        in
-        let rec loop = function
-            | [] ->
-                assert (not true);
-                TCP.P.AF.unspecified
-            | ai :: tl ->
-                match NI.specialize_sockaddr ai.NI.ai_addr TCP.P.AF.domain with
-                | None ->
-                    loop tl
-                | Some addr ->
-                    addr
-        in
-        let ais =
-            try NI.to_address (NI.A_bothnames (!host_, port)) with
-            | NI.Unresolved _ as x ->
-                jout#warn "unresolved remote address";
-                raise x
-        in
-        let addr = TCP.P.AF.of_sockaddr (loop ais) in
-        let host, port = addr in
-        let hostname = Cf_ip4_addr.ntop host in
-        jout#info "server at %s/%u" hostname port;
-        addr
-    
-    let sessions =
-        let n = !sessions_ in
-        if n < 1 then begin
-            usage specs_ usage_;
-            jout#fail "invalid number of sessions"
-        end;
-        let rec loop i =
-            lazy begin
-                if i < n then
-                    Cf_seq.P (i, loop (succ i))
-                else
-                    Cf_seq.Z
-            end
-        in
-        loop 0
-    
-    let count =
-        let n = !count_ in
-        if n < 1 then begin
-            usage specs_ usage_;
-            jout#fail "invalid number of messages to send per session"
-        end;
-        n
-end
-
-module type Main_T = sig
-    val reactor: G.kernel_t -> (unit, unit) G.t
-end
-
-module Main = struct
-    module M_tcp = Iom_sock_stream.Create(TCP)
-    
-    module N_map = Cf_rbtree.Map(Cf_ordered.Int_order)
-    
-    type mux_event_t =
-        | Mux_set of int * unit G.tx
-        | Mux_clr of int
-
-    let interrupt_ k =
-        G.simplex >>= fun (muxRx, muxTx) ->
-        let muxRx = (muxRx :> mux_event_t G.rx) in
-        G.simplex >>= fun (sigRx, sigTx) ->
-        let sigRx = (sigRx :> [ `Signal of int ] G.rx) in
-        G.simplex >>= fun (ctrlRx, ctrlTx) ->
-        let ctrlRx = (ctrlRx :> G.control_t G.rx) in
-        let ctrlTx = (ctrlTx :> G.control_t G.tx) in
-        Iom_reactor.signal ~c:ctrlRx ~r:sigTx ~n:Sys.sigint k >>= fun () ->
-        ctrlTx#put G.C_load >>= fun () ->
-        let rec loop () =
-            G.guard begin
-                sigRx#get do_sigRx_ >>= fun () ->
-                muxRx#get do_muxRx_
-            end
-        and do_sigRx_ (`Signal _) =
-            do_finish_ () >>= fun () ->
-            G.load >>= fun m ->
-            let z = N_map.to_seq_incr m in
-            let z = Cf_seq.second z in
-            let z = Cf_seq.map begin fun termTx ->
-                let termTx = (termTx :> unit G.tx) in
-                termTx#put ()
-            end z in
-            Cf_seq.C.sequence z
-        and do_muxRx_ cmd =
-            G.load >>= fun m ->
-            match cmd with
-            | Mux_set (n, termTx) ->
-                G.store (N_map.replace (n, termTx) m) >>= loop
-            | Mux_clr n ->
-                let m = N_map.delete n m in
-                if N_map.empty m then
-                    do_finish_ ()
-                else
-                    loop ()
-        and do_finish_ () =
-            ctrlTx#put G.C_unload >>= fun () ->
-            ctrlTx#put G.C_final
-        in
-        G.start (loop ()) N_map.nil >>= fun () ->
-        Cf_cmonad.return muxTx
-    
-    let session_ muxTx n sock k =
-        let muxTx = (muxTx :> mux_event_t G.tx) in
-        G.duplex >>= fun ((upRx, dnTx), ctrlIO) ->
-        let upRx = (upRx :> SR.endpoint_rx_t G.rx) in
-        let dnTx = (dnTx :> SR.endpoint_tx_t G.tx) in
-        M_tcp.endpoint ~c:ctrlIO sock k >>= fun () ->
-        G.simplex >>= fun (lineRx, lineTx) ->
-        let lineRx = (lineRx :> SR.endpoint_rx_t G.rx) in
-        Discipline.create upRx lineTx >>= fun () ->
-        let window = 256 in
-        dnTx#put (SR.IO_tx_window window) >>= fun () ->
-        let rec loop () =
-            G.guard begin
-                lineRx#get do_lineRx_
-            end
-        and do_lineRx_ = function
-            | SR.IO_rx_error x ->
-                jout#fail "Main.session_/do_lineRx_: incomplete! [IO_rx_error]"
-            | SR.IO_rx_data msg ->
-                let str = Cf_message.contents msg in
-                if String.length str > 0 && str.[0] = '[' then
-                    loop ()
-                else begin
-                    G.load >>= fun n ->
-                    if n < Opt.count then begin
-                        let n = succ n in
-                        putMessage_ n >>= fun () ->
-                        G.store n >>= fun () ->
-                        dnTx#put (SR.IO_tx_window window) >>= loop
-                    end
-                    else if n = Opt.count then begin
-                        let n = succ n in
-                        G.store n >>= fun () ->
-                        dnTx#put SR.IO_tx_release >>= loop
-                    end
-                    else
-                        loop ()
-                end
-            | SR.IO_rx_release ->
-                dnTx#put SR.IO_tx_release >>= fun () ->
-                muxTx#put (Mux_clr n)
-            | SR.IO_rx_blocked ->
-                dnTx#put (SR.IO_tx_window 0) >>= loop
-            | SR.IO_rx_ready ->
-                dnTx#put (SR.IO_tx_window window) >>= loop
-            | SR.IO_rx_closed ->
-                muxTx#put (Mux_clr n)
-            | SR.IO_rx_unlinked ->
-                jout#fail "Main.session_/do_lineRx_: incomplete! [IO_rx_unlinked]"
-        and putMessage_ n =
-            let str = Printf.sprintf "%u\r\n" n in
-            let msg = Cf_message.create str in
-            dnTx#put (SR.IO_tx_data msg)
-        in
-        G.start (putMessage_ 0) 0 >>= fun () ->
-        G.start (loop ()) 0
-
-    let connect_ muxTx n k =
-        let muxTx = (muxTx :> mux_event_t G.tx) in
-        G.simplex >>= fun (termRx, termTx) ->
-        let termRx = (termRx :> unit G.rx) in
-        muxTx#put (Mux_set (n, termTx)) >>= fun () ->
-        G.simplex >>= fun (inRx, inTx) ->
-        let inRx = (inRx :> M_tcp.initiator_rx_t G.rx) in
-        G.simplex >>= fun (cancelRx, cancelTx) ->
-        let cancelRx = (cancelRx :> unit G.rx) in
-        M_tcp.initiator ~c:inTx ~cancel:cancelRx Opt.server k >>= fun () ->
-        let rec loop () =
-            G.guard begin
-                inRx#get do_inRx_ >>= fun () ->
-                termRx#get do_termRx_
-            end
-        and do_inRx_ = function
-            | M_tcp.I_connect (sock, _, _) ->
-                session_ muxTx n sock k
-            | M_tcp.I_error x ->
-                muxTx#put (Mux_clr n) >>= fun () ->
-                begin
-                    try raise x with
-                    | Unix.Unix_error (error, _, _) ->
-                        let str = Unix.error_message error in
-                        jout#warn "unable to connect session %u (%s)" n str;
-                    | x ->
-                        let str = Printexc.to_string x in
-                        jout#warn "unable to connect session %u (%s)" n str;
-                end;
-                Cf_cmonad.return ()
-        and do_termRx_ () =
-            jout#fail "Main.connect_/do_termRx_: unimplemented!"
-        in
-        G.start (loop ()) ()
-
-    let reactor k =
-        interrupt_ k >>= fun muxTx ->
-        Cf_seq.C.sequence begin
-            Cf_seq.map begin fun i ->
-                connect_ muxTx i k
-            end Opt.sessions
-        end
-end
-
-let () =
-    Sys.set_signal Sys.sigpipe Sys.Signal_ignore;
-    begin
-        try G.run Main.reactor () with
-        | Unix.Unix_error (error, where, arg) ->
-            let error = Unix.error_message error in
-            jout#fail "Unix error: '%s' in %s(%s)\n" error where arg
-    end;
-    jout#info "orderly shutdown"
-
-(*--- End of Program [ t_mirrorc.ml ] ---*)

File iom/t/t_mirrord.ml

-(*---------------------------------------------------------------------------*
-  PROGRAM  t_mirrord.ml
-
-  Copyright (c) 2003-2005, 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
-let _ = jout#setlimit `None
-
-module G = Iom_gadget
-module SR = Iom_sock_stream
-
-open Cf_cmonad.Op
-
-module type Discipline_T = sig
-    val create:
-        SR.endpoint_rx_t #G.rx -> SR.endpoint_rx_t #G.tx -> ('s, unit) G.t
-end
-
-module Discipline: Discipline_T = struct
-    let search_crlf_ =
-        let rec loop n s =
-            match Lazy.force s with
-            | Cf_seq.P ('\r', tl) ->
-                let n = succ n in begin
-                    match Lazy.force tl with
-                    | Cf_seq.P ('\n', _) ->
-                        succ n
-                    | s ->
-                        loop n tl
-                end
-            | Cf_seq.P (_, tl) ->
-                loop (succ n) tl
-            | Cf_seq.Z ->
-                0
-        in
-        fun m ->
-            let s = Cf_message.to_seq m in
-            let pos = loop 0 s in
-            Cf_message.split ~pos m
-
-    module SC = Cf_scmonad
-
-    module type SM = sig
-        type ('s, 'i, 'o, 'a) t = ('s, ('i, 'o) Cf_flow.t, 'a) SC.t
-
-        val read: ('s, 'i, 'o, 'i) t
-        val write: 'o -> ('s, 'i, 'o, unit) t
-        val finish: ('s, 'i, 'o, unit) t
-    end
-
-    module SM: SM = struct
-        type ('s, 'i, 'o, 'a) t = ('s, ('i, 'o) Cf_flow.t, 'a) SC.t
-
-        let read f w = lazy (Cf_flow.Q (fun a -> Lazy.force (f a w)))
-        let write o a b = SC.cont (fun w -> lazy (Cf_flow.P (o, w))) a b
-        let finish a b = SC.init (Lazy.lazy_from_val Cf_flow.Z) a b
-    end
-
-    module C = Cf_cmonad
-    open SC.Op
-
-    let create =
-        let rec loop () =
-            SM.read >>= function
-            | (SR.IO_rx_release | SR.IO_rx_closed as event) ->
-                SC.load >>= begin function
-                | [] ->
-                    SM.write event >>= fun () ->
-                    SM.finish
-                | msg ->
-                    SM.write (SR.IO_rx_data msg) >>= fun () ->
-                    SM.write event >>= fun () ->
-                    SM.finish
-                end
-            | SR.IO_rx_data m1 ->
-                SC.load >>= begin fun m0 ->
-                let m0, m1 = search_crlf_ (m0 @ m1) in
-                match m0 with
-                | [] ->
-                    SC.store m1 >>= loop
-                | _ ->
-                    SM.write (SR.IO_rx_data m0) >>= fun () ->
-                    SC.store m1 >>= loop
-                end
-            | event ->
-                SM.write event
-        in
-        fun rx tx ->
-            let w =
-                let m =
-                    C.Op.( >>= ) (SC.down (loop ()) []) (fun _ -> C.return ())
-                in
-                C.eval m (Lazy.lazy_from_val Cf_flow.Z)
-            in
-            G.wrap rx tx w
-end
-
-module type Mirror_T = sig
-    type event_t =
-        | Ev_endpoint of Cf_tcp4_socket.endpoint
-        | Ev_terminate
-    
-    val create:
-        ev:event_t #G.rx -> G.kernel_t -> ('a, unit) G.t
-end
-
-module Mirror: Mirror_T = struct
-    type event_t =
-        | Ev_endpoint of Cf_tcp4_socket.endpoint
-        | Ev_terminate
-
-    module N_map = Cf_rbtree.Map(Cf_ordered.Int_order)
-    
-    type agent_t = {
-        a_header_: string;
-        a_output_: SR.endpoint_tx_t G.tx;
-        a_input_: SR.endpoint_rx_t G.rx;
-    }
-    
-    type state_t = {
-        s_map_: agent_t N_map.t;
-        s_nextkey_: int;
-        s_killed_: bool;
-    }
-    
-    let state0_ = {
-        s_map_ = N_map.nil;
-        s_nextkey_ = 0;
-        s_killed_ = false;
-    }
-        
-    let send_to_all_ m s =
-        let seq = Cf_seq.second (N_map.to_seq_decr s.s_map_) in
-        let seq =
-            Cf_seq.map (fun a -> a.a_output_#put (SR.IO_tx_data m)) seq
-        in
-        Cf_seq.C.sequence seq
-        
-    let release_all_ s =
-        let seq = Cf_seq.second (N_map.to_seq_decr s.s_map_) in
-        let seq =
-            Cf_seq.map (fun a -> a.a_output_#put SR.IO_tx_release) seq
-        in
-        Cf_seq.C.sequence seq
-    
-    let create ~ev k =
-        let evRx = (ev :> event_t G.rx) in
-        let rec loop () =
-            G.load >>= fun s ->
-            let seq = N_map.to_seq_decr s.s_map_ in
-            let seq = Cf_seq.map (get_agentRx_ s) seq in
-            G.guard begin
-                Cf_seq.C.sequence seq >>= fun () ->
-                get_evRx_ s
-            end
-        and get_agentRx_ s (n, a) =
-            a.a_input_#get begin function
-                | SR.IO_rx_data m ->
-                    a.a_output_#put (SR.IO_tx_window 256) >>= fun () ->
-                    let str = Cf_message.contents m in
-                    let str = Printf.sprintf "%s> %s" a.a_header_ str in
-                    jout#info "%s" str;
-                    let m = Cf_message.create str in
-                    if not s.s_killed_ then
-                        send_to_all_ m s >>= loop
-                    else
-                        loop ()
-                | SR.IO_rx_release ->
-                    let s = { s with s_map_ = N_map.delete n s.s_map_ } in
-                    G.store s >>= fun () ->
-                    if not s.s_killed_ then begin
-                        let str =
-                            Printf.sprintf "[%s Released]\r\n" a.a_header_
-                        in
-                        jout#info "%s" str;
-                        let m = Cf_message.create str in
-                        send_to_all_ m s >>= fun () ->
-                        a.a_output_#put SR.IO_tx_release >>= loop
-                    end
-                    else
-                        a.a_output_#put SR.IO_tx_release >>= loop
-                | SR.IO_rx_closed ->
-                    jout#info "Closed %s" a.a_header_;
-                    let s = { s with s_map_ = N_map.delete n s.s_map_ } in
-                    if s.s_killed_ && N_map.empty s.s_map_ then
-                        Cf_cmonad.return ()
-                    else
-                        G.store s >>= loop
-                | SR.IO_rx_error error ->
-                    let s = { s with s_map_ = N_map.delete n s.s_map_ } in
-                    G.store s >>= fun () ->
-                    if not s.s_killed_ then begin
-                        let str =
-                            let msg = Printexc.to_string error in
-                            Printf.sprintf "[%s Error %s]\r\n" a.a_header_ msg
-                        in
-                        jout#info "%s" str;
-                        let m = Cf_message.create str in
-                        send_to_all_ m s >>= loop
-                    end
-                    else
-                        loop ()
-                | (SR.IO_rx_ready | SR.IO_rx_blocked) -> 
-                    loop ()
-                | SR.IO_rx_unlinked ->
-                    assert (not true);
-                    Cf_cmonad.return ()
-            end
-        and get_evRx_ s =
-            evRx#get begin function
-                | Ev_endpoint e ->
-                    if s.s_killed_ then begin
-                        e#close;
-                        loop ()
-                    end
-                    else begin
-                        let rhost, rport = e#getpeername in
-                        let rhost = Cf_ip4_addr.ntop rhost in
-                        let header = Printf.sprintf "%s/%d" rhost rport in
-                        let cmsg = Printf.sprintf "[Connect %s]\r\n" header in
-                        jout#info "%s" cmsg;
-                        let cmsg = Cf_message.create cmsg in
-                        G.duplex >>= fun ((erRx, ecTx), (ecRx, erTx as c)) ->
-                        let ecTx = (ecTx :> SR.endpoint_tx_t G.tx) in
-                        Iom_tcp4_socket.endpoint ~c e#socket k >>= fun () ->
-                        G.simplex >>= fun (lineRx, lineTx) ->
-                        Discipline.create erRx lineTx >>= fun () ->
-                        ecTx#put (SR.IO_tx_window 256) >>= fun () ->
-                        let a = {
-                            a_header_ = header;
-                            a_input_ = lineRx;
-                            a_output_ = ecTx;
-                        } in
-                        let nextkey = s.s_nextkey_ in
-                        let map = N_map.replace (nextkey, a) s.s_map_ in
-                        let s = {
-                            s with
-                            s_nextkey_ = succ nextkey;
-                            s_map_ = map;
-                        } in
-                        let seq = N_map.to_seq_decr s.s_map_ in
-                        G.store s >>= fun () ->
-                        send_to_all_ cmsg s >>= loop
-                    end
-                | Ev_terminate ->
-                    if N_map.empty s.s_map_ then
-                        Cf_cmonad.return ()
-                    else begin
-                        let s = { s with s_killed_ = true } in
-                        G.store s >>= fun () ->
-                        let str = "[Terminated]\r\n" in
-                        jout#info "%s" str;
-                        let tmsg = Cf_message.create str in
-                        send_to_all_ tmsg s >>= fun () ->
-                        release_all_ s >>= loop
-                    end
-            end
-        in
-        G.start (loop ()) state0_
-end
-
-module type Main_T = sig
-    val reactor: G.kernel_t -> (unit, unit) G.t
-end
-
-module Main: Main_T = struct
-    let interrupt_ ~ev ~lt k =
-        let ev = (ev :> Mirror.event_t G.tx) in
-        let lt = (lt :> unit G.tx) in
-        G.simplex >>= fun (rin, rout) ->
-        let rin = (rin :> [ `Signal of int ] G.rx) in
-        Iom_reactor.signal ~r:rout ~n:Sys.sigint k >>= fun () ->
-        let rec loop () =
-            G.guard begin
-                rin#get begin function `Signal _ ->
-                    ev#put Mirror.Ev_terminate >>= fun () ->
-                    lt#put ()
-                end
-            end
-        in
-        G.start (loop ()) ()
-    
-    let listener_ ~ev ~lt k =
-        let ev = (ev :> Mirror.event_t G.tx) in
-        let lt = (lt :> unit G.rx) in
-        G.duplex >>= fun ((lr, lc), c) ->
-        let address = (Cf_ip4_addr.any :> Cf_ip4_addr.opaque Cf_ip4_addr.t) in
-        Iom_tcp4_socket.listener ~c ~qlen:10 (address, 0) k >>= fun () ->
-        let lc = (lc :> Iom_tcp4_socket.listener_tx_t G.tx) in
-        let lr = (lr :> Iom_tcp4_socket.listener_rx_t G.rx) in
-        let rec loop () =
-            G.guard begin
-                get_listenRx_ () >>= fun () ->
-                get_ltRx_ ()
-            end
-        and get_listenRx_ () =
-            lr#get begin function
-            | Iom_tcp4_socket.L_error error ->
-                raise error (* handle fd table overflow here *)
-            | Iom_tcp4_socket.L_bind (node, port) ->
-                let node = Cf_ip4_addr.ntop node in
-                jout#info "listening at %s:%d\n" node port;
-                flush stdout;
-                lc#put (Iom_tcp4_socket.L_limit 10) >>= loop
-            | Iom_tcp4_socket.L_connect (socket, _, _) ->
-                lc#put (Iom_tcp4_socket.L_extend 1) >>= fun () ->
-                let e = new Cf_tcp4_socket.endpoint socket in
-                ev#put (Mirror.Ev_endpoint e) >>= loop
-            end
-        and get_ltRx_ () =
-            lt#get (fun () -> lc#put Iom_tcp4_socket.L_close)
-        in
-        G.start (loop ()) ()
-    
-    let reactor k =
-        G.simplex >>= fun (mevin, mevout) ->
-        Mirror.create ~ev:mevin k >>= fun () ->
-        G.simplex >>= fun (ltRx, ltTx) ->
-        listener_ ~ev:mevout ~lt:ltRx k >>= fun () ->
-        interrupt_ ~ev:mevout ~lt:ltTx k
-end
-
-
-let () =
-    Sys.set_signal Sys.sigpipe Sys.Signal_ignore;
-    begin
-        try G.run Main.reactor () with
-        | Unix.Unix_error (error, where, arg) ->
-            let error = Unix.error_message error in
-            jout#fail "Unix error: '%s' in %s(%s)\n" error where arg
-    end;
-    jout#info "orderly shutdown"
-
-(*--- End of Program [ t_mirrord.ml ] ---*)