Commits

Anonymous committed 6c247fe

Checkpoint. Merged from PAGODA branch to top of tree.

Comments (0)

Files changed (1)

 
 (* let gc = Gc.get () in gc.Gc.verbose <- 0x91; Gc.set gc;; *)
 
+(**)
+let jout = Cf_journal.stdout;;
+jout#setlimit `None;;
+(**)
+
+(*
 module type X_tag = sig
     val tag: string
 end
     let sprintf (fmt : ('a, unit, string) format) =
         Printf.sprintf (Obj.magic (tag ^ (Obj.magic fmt)))
 end
+*)
 
 module T1 = struct
-    module X = X_create(struct let tag = "T1" end)
+    (* module X = X_create(struct let tag = "T1" end) *)
     
     let header channel msgno seqno = {
         Beep_frame.channel = Int32.of_int channel;
             failwith "Frame.parse: no frame parsed"
 end
 
-module T2 = struct
-    module X = X_create(struct let tag = "T2" end)
-    
+module Foo_loopback = struct
     open Iom_reactor
     open Cf_cmonad.Op
-    
-    module Sock_tcp = Cf_tcp6_socket
-    module Iom_tcp = Iom_tcp6_socket
-    module INADDR = Cf_ip6_addr
-    let any_address = INADDR.unspecified
-    
+
     module E = Beep_exchange
+    module C = Beep_channel
     module U = Beep_transport
-    module U_tcp = Beep_tcp6_endpoint
-    module C = Beep_channel
-
-    type top_event_t =
-        | Top_error of exn
-        | Top_listen of Sock_tcp.address_t
-        | Top_connect of Sock_tcp.t
-        | Top_final
-        
-    let initiator_ topTx addr k =
-        let topTx = (topTx :> top_event_t tx) in
-        simplex >>= fun (ctrlRx, ctrlTx) ->
-        Iom_tcp.initiator ~c:ctrlTx addr k >>= fun () ->
-        let ctrlRx = (ctrlRx :> Iom_tcp.initiator_rx_t rx) in
-        let guard () = guard begin
-            ctrlRx#get begin fun i ->
-                topTx#put begin
-                    match i with
-                    | Iom_tcp.I_connect (sock, _, _) -> Top_connect sock
-                    | Iom_tcp.I_error error -> Top_error error
-                end
-            end
-        end in
-        start (guard ()) ()
-    
-    let listener_ topTx k =
-        let topTx = (topTx :> top_event_t tx) in
-        let address = (any_address, 0 :> Sock_tcp.address_t) in
-        duplex >>= fun (c, (lRx, lTx)) ->
-        Iom_tcp.listener ~c address k >>= fun () ->
-        let lRx = (lRx :> Iom_tcp.listener_rx_t rx) in
-        let lTx = (lTx :> Iom_tcp.listener_tx_t tx) in
-        let rec loop () = guard begin
-            lRx#get begin function
-            | Iom_tcp.L_error error ->
-                topTx#put (Top_error error)
-            | Iom_tcp.L_connect (socket, _, _) ->
-                lTx#put Iom_tcp.L_close >>= fun () ->
-                topTx#put (Top_connect socket)
-            | Iom_tcp.L_bind address ->
-                lTx#put (Iom_tcp.L_limit 1) >>= fun () ->
-                topTx#put (Top_listen address) >>= loop
-            end
-        end in
-        start (loop ()) ()
     
     module E_foo = struct
         open Cf_parser.Op
                             let cMsg = C.M_close.cons 200 in
                             ctrlTx#put (C.C_tx_close cMsg) >>= loop
                         | C.C_rx_close closeMsg ->
-                            failwith
-                              (X.sprintf
-                                "client#reactor: incomplete! [C_rx_close]");
-                            Cf_cmonad.return ()
+                            jout#fail
+                                "client#reactor: incomplete! [C_rx_close]";
                         | C.C_rx_error errorMsg ->
-                            failwith
-                              (X.sprintf
-                                "client#reactor: incomplete! [C_rx_error]");
-                            Cf_cmonad.return ()
+                            jout#fail
+                                "client#reactor: incomplete! [C_rx_error]";
                         | C.C_rx_release ->
                             doneTx#put ()
                         | C.C_rx_abort ->
-                            failwith
-                              (X.sprintf
-                                "client#reactor: incomplete! [C_rx_abort]");
-                            Cf_cmonad.return ()
+                            jout#fail
+                                "client#reactor: incomplete! [C_rx_abort]";
                     end
                 in
                 start (loop ()) ()
                             | C.CS_profile (_, profileTx) ->
                                 profileTx#put (self :> C.profile)
                             | C.CS_error errorMsg ->
-                                failwith (X.sprintf "client#connect: error");
-                                Cf_cmonad.return ()
+                                jout#fail "client#connect: incomplete!"
                         end
                     end
                 in
                         | C.C_rx_close closeMsg ->
                             ctrlTx#put C.C_tx_release
                         | _ ->
-                            failwith
-                              (X.sprintf "service#reactor: incomplete! [1]");
-                            Cf_cmonad.return ()
+                            jout#fail "service#reactor: incomplete!"
                     end
                 in
                 let c = new foo_client in
                 simplex >>= fun (accRx, accTx) ->
                 let accRx = (accRx :> C.service_start_t rx) in
                 let accTx = (accTx :> C.service_start_t tx) in
-                let profile = (self :> C.profile) in
-                accTx#put (C.SS_profile (e_profile_, profile)) >>= fun () ->
+                simplex >>= fun (profRx, profTx) ->
+                let profRx = (profRx :> C.profile rx) in
+                let profTx = (profTx :> C.profile tx) in
+                profTx#put (self :> C.profile) >>= fun () ->
+                let ss = C.SS_profile (e_profile_, None, profRx) in
+                accTx#put ss >>= fun () ->
                 Cf_cmonad.return (Some accRx)
         end
     
     let client_ topTx ctrlRx ctrlTx textPair =
-        let topTx = (topTx :> top_event_t tx) in
+        let topTx = (topTx :> 'top tx) in
         let ctrlRx = (ctrlRx :> U.control_rx_t rx) in
         let ctrlTx = (ctrlTx :> U.control_tx_t tx) in
         simplex >>= fun (doneRx, doneTx) ->
             end
         and get_ctrlRx_ = function
             | U.C_rx_failure x ->
-                topTx#put (Top_error x)
+                topTx#put (`Error x)
             | U.C_rx_greeting _
             | U.C_rx_error _ ->
                 assert (not true);
                 loop ()
             | U.C_rx_close closeMsg ->
-                failwith
-                (X.sprintf "client_/get_ctrlRx_: incomplete! [C_rx_close]")
+                jout#fail "client_/get_ctrlRx_: incomplete! [C_rx_close]"
             | U.C_rx_reset ->
-                failwith
-                (X.sprintf "client_/get_ctrlRx_: incomplete! [C_rx_reset]")
+                jout#fail "client_/get_ctrlRx_: incomplete! [C_rx_reset]"
             | U.C_rx_final ->
-                topTx#put Top_final
+                topTx#put `Final
         and get_doneRx_ () =
             ctrlTx#put (U.C_tx_close (C.M_close.cons 200)) >>= loop
         in
         start (loop ()) `Initial
     
     let service_ topTx ctrlRx ctrlTx textPair =
-        let topTx = (topTx :> top_event_t tx) in
+        let topTx = (topTx :> 'top tx) in
         let ctrlRx = (ctrlRx :> U.control_rx_t rx) in
         let ctrlTx = (ctrlTx :> U.control_tx_t tx) in
         let rec loop () = guard (ctrlRx#get get_ctrlRx_)
         and get_ctrlRx_ = function
             | U.C_rx_failure x ->
-                topTx#put (Top_error x)
+                topTx#put (`Error x)
             | U.C_rx_greeting _
             | U.C_rx_error _ ->
                 assert (not true);
             | U.C_rx_close _ ->
                 ctrlTx#put U.C_tx_release >>= loop                
             | U.C_rx_reset ->
-                failwith
-                (X.sprintf "service_/get_ctrlRx_: incomplete! [C_rx_reset]")
+                jout#fail "service_/get_ctrlRx_: incomplete! [C_rx_reset]"
             | U.C_rx_final ->
-                topTx#put Top_final
+                topTx#put `Final
         in
         start (loop ()) `Initial
 
-    let greet_ topTx ctrlRx ctrlTx textPair role =
-        let topTx = (topTx :> top_event_t tx) in
+    let greet_ topTx ctrlRx ctrlTx role k =
+        let textPair = "foo\r\n", "bar\r\n" in
+        let topTx = (topTx :> 'top tx) in
         let ctrlRx = (ctrlRx :> U.control_rx_t rx) in
         let ctrlTx = (ctrlTx :> U.control_tx_t tx) in
+        let greetCmd =
+            let srv = new service textPair in
+            U.C_tx_greeting (U.M_greeting.default, (srv :> C.service) :: [])
+        in
         let rec loop () = guard (ctrlRx#get get_ctrlRx_)
         and get_ctrlRx_ = function
             | U.C_rx_failure x ->
-                topTx#put (Top_error x)
+                topTx#put (`Error x)
             | U.C_rx_greeting greetingMsg ->
                 if greetingMsg <> U.M_greeting.default then
-                    failwith
-                        (X.sprintf "greet_/get_ctrlRx_: unexpected content");
+                    jout#fail "greet_/get_ctrlRx_: unexpected content";
                 if role == U.R_initiator then
                     client_ topTx ctrlRx ctrlTx textPair
-                else
+                else begin
+                    ctrlTx#put greetCmd >>= fun () ->
                     service_ topTx ctrlRx ctrlTx textPair
+                end
             | U.C_rx_error errorMsg ->
-                failwith
-                (X.sprintf "greet_/get_ctrlRx_: incomplete! [C_rx_error]")
+                jout#fail "greet_/get_ctrlRx_: incomplete! [C_rx_error]"
             | U.C_rx_close _
             | U.C_rx_reset
             | U.C_rx_final ->
                 assert (not true);
                 Cf_cmonad.return ()
         in
-        let greetCmd =
-            let srv = new service textPair in
-            U.C_tx_greeting (U.M_greeting.default, (srv :> C.service) :: [])
-        in
-        ctrlTx#put greetCmd >>= fun () ->
+        begin
+            if role == U.R_initiator then
+                ctrlTx#put greetCmd
+            else
+                Cf_cmonad.return ()
+        end >>= fun () ->
         start (loop ()) `Initial
+end
 
-    let exchange_ topTx role textPair socket k =
+module type Loopback_Profile_T = sig
+    module Socket: Cf_sock_stream.T    
+    val any_address: Socket.address_t
+    val tcp_nodelay:
+        (bool, Socket.P.AF.tag_t, Socket.P.ST.tag_t) Cf_socket.sockopt_t
+end
+
+module type Loopback_T = sig
+    module Socket: Cf_sock_stream.T
+
+    type top_event_t = [
+        | `Error of exn
+        | `Listen of Socket.address_t
+        | `Connect of Socket.t
+        | `Final
+    ]
+
+    module UM: Beep_tcp_mapping.T
+    
+    class virtual core:
+        object
+            val mutable okay_: bool
+            
+            method private virtual client_:
+                's 'a 'x.
+                (([> `Final | `Error of exn ] as 'x) #Iom_reactor.tx as 'a) ->
+                UM.S.t -> Iom_reactor.kernel_t -> ('s, unit) Iom_reactor.t
+            
+            method private virtual service_:
+                's 'a 'x.
+                (([> `Final | `Error of exn ] as 'x) #Iom_reactor.tx as 'a) ->
+                UM.S.t -> Iom_reactor.kernel_t -> ('s, unit) Iom_reactor.t
+
+            method private initiator_:
+                's 'a. (top_event_t #Iom_reactor.tx as 'a) ->
+                UM.S.address_t -> Iom_reactor.kernel_t ->
+                ('s, unit) Iom_reactor.t
+
+            method private listener_:
+                's 'a. (top_event_t #Iom_reactor.tx as 'a) ->
+                Iom_reactor.kernel_t -> ('s, unit) Iom_reactor.t
+
+            method private reactor_:
+                's. Iom_reactor.kernel_t -> ('s, unit) Iom_reactor.t
+
+            method test: unit -> unit
+        end
+end
+
+module Loopback(P: Loopback_Profile_T): Loopback_T = struct
+    open Iom_reactor
+    open Cf_cmonad.Op
+    
+    module Socket = P.Socket
+    module Iom = Iom_sock_stream.Create(P.Socket)
+
+    module U = Beep_transport
+    module UM = Beep_tcp_mapping.Create(P.Socket)
+
+    type top_event_t = [
+        | `Error of exn
+        | `Listen of UM.S.address_t
+        | `Connect of UM.S.t
+        | `Final
+    ]
+    
+    let initiator_ topTx addr k =
         let topTx = (topTx :> top_event_t tx) in
-        Cf_socket.setsockopt socket Cf_ip_common.tcp_nodelay true;
-        U_tcp.create socket role k >>= fun (ctrlRx, ctrlTx) ->
-        let ctrlTx = (ctrlTx :> U.control_tx_t tx) in
-        greet_ topTx ctrlRx ctrlTx textPair role
-        
-    let okay_ = ref false
-
-    let reactor_ k =
-        simplex >>= fun (topRx, topTx) ->
-        let topRx = (topRx :> top_event_t rx) in
-        listener_ topTx k >>= fun () ->
-        let rec loop () = guard begin
-            topRx#get begin function
-            | Top_error error -> begin
-                try raise error with
-                | Beep_error.X berror ->
-                    let explain = Beep_error.to_string berror in
-                    failwith (X.sprintf "transport error: \"%s\"" explain)
-            end
-            | Top_listen addr ->
-                initiator_ topTx addr k >>= loop
-            | Top_connect socket ->
-                load >>= begin function
-                | `Init ->
-                    store `Connecting >>= fun () ->
-                    let pair = "foo\r\n", "bar\r\n" in
-                    exchange_ topTx U.R_initiator pair socket k >>= loop
-                | `Connecting ->
-                    store (`Receiving 2) >>= fun () ->
-                    let pair = "bar\r\n", "foo\r\n" in
-                    exchange_ topTx U.R_listener pair socket k >>= loop
-                | _ ->
-                    failwith "toploop_: `Connect state error"
-                end
-            | Top_final ->
-                load >>= begin function
-                | `Receiving n when n > 0 ->
-                    let n = pred n in
-                    let s =
-                        if n > 0 then
-                            `Receiving n
-                        else begin
-                            okay_ := true;
-                            `Done
-                        end
-                    in
-                    store s >>= loop
-                | _ ->
-                    failwith "toploop_: Top_final state error"
+        simplex >>= fun (ctrlRx, ctrlTx) ->
+        Iom.initiator ~c:ctrlTx addr k >>= fun () ->
+        let ctrlRx = (ctrlRx :> Iom.initiator_rx_t rx) in
+        let guard () = guard begin
+            ctrlRx#get begin fun i ->
+                topTx#put begin
+                    match i with
+                    | Iom.I_connect (sock, _, _) -> `Connect sock
+                    | Iom.I_error error -> `Error error
                 end
             end
         end in
-        start (loop ()) `Init
+        start (guard ()) ()
 
-    let test_aux i =
-        (*
-        X.printf ">>> loop %u\n" i;
-        Gc.print_stat stdout;
-        flush stdout;
-        *)
-        (*
-        print_char '.';
-        flush stdout;
-        *)
-        try
-            run reactor_ ();
-            if not !okay_ then
-                failwith "reactor: processing completed early.";
-            (*
-            X.printf "<<< loop %u\n\n" i;
-            flush stdout
-            *)
-        with
-        | Unix.Unix_error (error, fname, arg) ->
-            let msg =
-                let error = Unix.error_message error in
-                Printf.sprintf
-                    "Unix error \"%s\" in %s(%s).\n" error fname arg
-            in
-            failwith msg
-        | x ->
-            raise x
+    let listener_ topTx k =
+        let topTx = (topTx :> top_event_t tx) in
+        duplex >>= fun (c, (lRx, lTx)) ->
+        Iom.listener ~c P.any_address k >>= fun () ->
+        let lRx = (lRx :> Iom.listener_rx_t rx) in
+        let lTx = (lTx :> Iom.listener_tx_t tx) in
+        let rec loop () = guard begin
+            lRx#get begin function
+            | Iom.L_error error ->
+                topTx#put (`Error error)
+            | Iom.L_connect (socket, _, _) ->
+                lTx#put Iom.L_close >>= fun () ->
+                topTx#put (`Connect socket)
+            | Iom.L_bind address ->
+                lTx#put (Iom.L_limit 1) >>= fun () ->
+                topTx#put (`Listen address) >>= loop
+            end
+        end in
+        start (loop ()) ()
+
+    class virtual core =
+        object(self)
+            val mutable okay_ = false
+            
+            method private virtual client_:
+                's 'a 'x.
+                (([> `Final | `Error of exn ] as 'x) #Iom_reactor.tx as 'a) ->
+                UM.S.t -> Iom_reactor.kernel_t -> ('s, unit) Iom_reactor.t
+            
+            method private virtual service_:
+                's 'a 'x.
+                (([> `Final | `Error of exn ] as 'x) #Iom_reactor.tx as 'a) ->
+                UM.S.t -> Iom_reactor.kernel_t -> ('s, unit) Iom_reactor.t
+
+            method private initiator_:
+                's 'a. (top_event_t #tx as 'a) -> UM.S.address_t ->
+                kernel_t -> ('s, unit) t = initiator_
+                
+            method private listener_:
+                's 'a. (top_event_t #tx as 'a) -> kernel_t -> ('s, unit) t =
+                listener_
+
+            method private reactor_:
+                's. kernel_t -> ('s, unit) t =
+                fun k ->
+                    simplex >>= fun (topRx, topTx) ->
+                    let topRx = (topRx :> top_event_t rx) in
+                    let topTx = (topTx :> top_event_t tx) in
+                    self#listener_ topTx k >>= fun () ->
+                    let rec loop () =
+                        guard (topRx#get do_topRx_)
+                    and do_topRx_ = function
+                        | `Error error ->
+                            raise error
+                        | `Listen addr ->
+                            self#initiator_ topTx addr k >>= loop
+                        | `Connect socket ->
+                            do_topRx_connect socket
+                        | `Final ->
+                            do_topRx_final ()
+                    and do_topRx_connect socket =
+                        Cf_socket.setsockopt socket P.tcp_nodelay true;
+                        let topTx = (topTx :> [ `Final | `Error of exn ] tx) in
+                        load >>= function
+                        | `Init ->
+                            store `Connecting >>= fun () ->
+                            self#client_ topTx socket k >>= loop
+                        | `Connecting ->
+                            store (`Receiving 2) >>= fun () ->
+                            self#service_ topTx socket k >>= loop
+                        | _ ->
+                            assert (not true);
+                            Cf_cmonad.return ()
+                    and do_topRx_final () =
+                        load >>= function
+                        | `Receiving n when n > 0 ->
+                            let n = pred n in
+                            let s =
+                                if n > 0 then
+                                    `Receiving n
+                                else begin
+                                    okay_ <- true;
+                                    `Done
+                                end
+                            in
+                            store s >>= loop
+                        | _ ->
+                            assert (not true);
+                            Cf_cmonad.return ()
+                    in
+                    start (loop ()) `Init
+
+            method test () =
+                try
+                    run self#reactor_ ();
+                    if not okay_ then
+                        jout#fail "loopback: reactor completed early.";
+                with
+                | Unix.Unix_error (error, fname, arg) ->
+                    let error = Unix.error_message error in
+                    jout#fail
+                        "Unix error \"%s\" in %s(%s).\n" error fname arg
+                | Sasl_error.X error ->
+                    jout#fail
+                        "SASL error \"%s\"" (Sasl_error.to_string error)
+                | Beep_error.X error ->
+                    jout#fail
+                        "BEEP error \"%s\"" (Beep_error.to_string error)
+                | x ->
+                    raise x
+        end
+end
+
+module TCP4_Loopback_Profile: Loopback_Profile_T = struct
+    module Socket = Cf_tcp4_socket
+    let any_address = (Cf_ip4_addr.any, 0 :> Socket.address_t)
+    let tcp_nodelay = Cf_ip_common.tcp_nodelay
+end
+
+module TCP6_Loopback_Profile: Loopback_Profile_T = struct
+    module Socket = Cf_tcp6_socket
+    let any_address = (Cf_ip6_addr.unspecified, 0 :> Socket.address_t)
+    let tcp_nodelay = Cf_ip_common.tcp_nodelay
+end
+
+module TCP4_loopback = Loopback(TCP4_Loopback_Profile)
+module TCP6_loopback = Loopback(TCP6_Loopback_Profile)
+
+module T2 = struct
+    open Iom_reactor
+    open Cf_cmonad.Op
+    
+    module L = TCP6_loopback
+    module U = Beep_transport
+
+    let obj = object
+        inherit L.core
+        
+        method private client_ topTx socket k =
+            L.UM.create socket U.R_initiator k >>= fun (ctrlRx, ctrlTx) ->
+            let ctrlRx = (ctrlRx :> U.control_rx_t rx) in
+            let ctrlTx = (ctrlTx :> U.control_tx_t tx) in
+            Foo_loopback.greet_ topTx ctrlRx ctrlTx U.R_initiator k
+        
+        method private service_ topTx socket k =
+            L.UM.create socket U.R_listener k >>= fun (ctrlRx, ctrlTx) ->
+            let ctrlRx = (ctrlRx :> U.control_rx_t rx) in
+            let ctrlTx = (ctrlTx :> U.control_tx_t tx) in
+            Foo_loopback.greet_ topTx ctrlRx ctrlTx U.R_listener k
+    end
     
     let test () =
-        for i = 1 to 3 do test_aux i done
+        for i = 1 to 1 do obj#test () done
+end
+
+module type SASL_Loopback_Profile_T = sig
+    module L0: Loopback_T
+    
+    type id_t
+    type query_t
+    type credential_t
+    
+    class supplicant: [id_t, query_t, credential_t] Sasl_supplicant.core
+    class authenticator: [id_t, credential_t] Sasl_authenticator.core
+    
+    val sasl_clients:
+        ((id_t, query_t, credential_t) Sasl_supplicant.request_t
+            #Iom_reactor.tx -> id_t Sasl_mechanism.client) list
+    
+    val sasl_services:
+        ((id_t, credential_t) Sasl_authenticator.request_t
+            #Iom_reactor.tx -> id_t Sasl_mechanism.service) list
+end
+
+module type SASL_Loopback_T = sig
+    module P: SASL_Loopback_Profile_T
+
+    class client:
+        g:Beep_channel.M_profile.t list -> ?srv:string ->
+        ?loc:#Beep_locale.t ->
+        (P.id_t, P.query_t, P.credential_t) Sasl_supplicant.request_t
+            #Iom_reactor.tx ->
+        Beep_sasl.client_tx_t #Iom_reactor.rx ->
+        P.id_t Beep_sasl.control_rx_t #Iom_reactor.tx -> Beep_sasl.client
+
+    class service:
+        ?loc:#Beep_locale.t ->
+        (P.id_t, P.credential_t) Sasl_authenticator.request_t 
+            #Iom_reactor.tx ->
+        P.id_t Beep_sasl.control_rx_t #Iom_reactor.tx ->
+        Beep_sasl.service
+
+    class virtual core:
+        object
+            inherit P.L0.core
+                        
+            method private virtual client2_:
+                's 'a 'x.
+                (([> `Final | `Error of exn ] as 'x) #Iom_reactor.tx as 'a) ->
+                P.L0.UM.S.t -> Iom_reactor.kernel_t -> ('s, unit) Iom_reactor.t
+            
+            method private virtual service2_:
+                's 'a 'x.
+                (([> `Final | `Error of exn ] as 'x) #Iom_reactor.tx as 'a) ->
+                P.L0.UM.S.t -> Iom_reactor.kernel_t -> ('s, unit) Iom_reactor.t
+            
+            method private client_:
+                's 'a 'x.
+                (([> `Final | `Error of exn ] as 'x) #Iom_reactor.tx as 'a) ->
+                P.L0.UM.S.t -> Iom_reactor.kernel_t -> ('s, unit) Iom_reactor.t
+            
+            method private service_:
+                's 'a 'x.
+                (([> `Final | `Error of exn ] as 'x) #Iom_reactor.tx as 'a) ->
+                P.L0.UM.S.t -> Iom_reactor.kernel_t -> ('s, unit) Iom_reactor.t
+        end
+end
+
+module SASL_loopback(P: SASL_Loopback_Profile_T):
+    (SASL_Loopback_T with module P = P) =
+struct
+    open Iom_reactor
+    open Cf_cmonad.Op
+    
+    module P = P
+    
+    module U = Beep_transport
+    module C = Beep_channel
+    module E = Beep_exchange
+    
+    class client ~g ?srv ?loc suppTxTx =
+        let m = List.map (fun c -> c suppTxTx) P.sasl_clients in
+        Beep_sasl.client ~m ~g ?srv ?loc
+    
+    class service ?loc authTxTx =
+        let m = List.map (fun c -> c authTxTx) P.sasl_services in
+        Beep_sasl.service ~m ?loc
+    
+    let supplicant = new P.supplicant
+    let authenticator = new P.authenticator
+        
+    class virtual core =
+        object(self)
+            inherit P.L0.core
+                        
+            method private virtual client2_:
+                's 'a 'x.
+                (([> `Final | `Error of exn ] as 'x) #Iom_reactor.tx as 'a) ->
+                P.L0.UM.S.t -> Iom_reactor.kernel_t -> ('s, unit) Iom_reactor.t
+            
+            method private virtual service2_:
+                's 'a 'x.
+                (([> `Final | `Error of exn ] as 'x) #Iom_reactor.tx as 'a) ->
+                P.L0.UM.S.t -> Iom_reactor.kernel_t -> ('s, unit) Iom_reactor.t
+
+            method private client_ topTx socket k =
+                let topTx = (topTx :> [ `Final | `Error of exn ] tx) in
+                P.L0.UM.create socket U.R_initiator k >>=
+                    fun (ctrlRx, ctrlTx) ->
+                let ctrlRx = (ctrlRx :> U.control_rx_t rx) in
+                let ctrlTx = (ctrlTx :> U.control_tx_t tx) in
+                let rec loop () =
+                    load >>= fun s ->
+                    guard begin
+                        ctrlRx#get do_ctrlRx_ >>= fun () ->
+                        match s with
+                        | `Greeting ->
+                            Cf_cmonad.return ()
+                        | `Tuning (clRx, clTx) ->
+                            let clRx = (clRx :> 'clrx rx) in
+                            let clTx = (clTx :> 'cltx tx) in
+                            clRx#get (do_clRx_ clRx clTx)
+                    end
+                and do_ctrlRx_ event =
+                    match event with
+                    | U.C_rx_failure x -> do_ctrlRx_failure_ x
+                    | U.C_rx_greeting greetMsg -> do_ctrlRx_greeting_ greetMsg
+                    | U.C_rx_error errorMsg -> do_ctrlRx_error_ errorMsg
+                    | U.C_rx_close closeMsg -> do_ctrlRx_close_ closeMsg
+                    | U.C_rx_reset -> do_ctrlRx_reset_ ()
+                    | U.C_rx_final -> do_ctrlRx_final_ ()
+                and do_ctrlRx_failure_ x =
+                    topTx#put (`Error x)
+                and do_ctrlRx_greeting_ greetMsg =
+                    load >>= function
+                    | `Greeting ->
+                        duplex >>= fun ((clRx, clTx), (clRx', clTx')) ->
+                        Sasl_supplicant.start supplicant >>= fun suppTxTx ->
+                        let suppTxTx =
+                            (suppTxTx :> (P.id_t, P.query_t, P.credential_t)
+                                Sasl_supplicant.request_t tx)
+                        in
+                        let g = greetMsg.U.M_greeting.profiles in
+                        let clientObj = new client ~g suppTxTx clRx clTx in
+                        ctrlTx#put (U.C_tx_start clientObj) >>= fun () ->
+                        store (`Tuning (clRx', clTx')) >>= loop
+                    | `Tuning (_, _) ->
+                        jout#fail "SASL_loopback.core#client_: \
+                            do_ctrlRx_greeting_ already tuning!"
+                and do_ctrlRx_error_ x =
+                    jout#fail "SASL_loopback.core#client_: \
+                        do_ctrlRx_error_ unimplemented!"
+                and do_ctrlRx_close_ x =
+                    jout#fail "SASL_loopback.core#client_: \
+                        do_ctrlRx_close_ unimplemented!"
+                and do_ctrlRx_reset_ x =
+                    self#client2_ topTx socket k
+                and do_ctrlRx_final_ x =
+                    jout#fail "SASL_loopback.core#client_: \
+                        do_ctrlRx_final_ unimplemented!"
+                and do_clRx_ clRx clTx = function
+                    | Beep_sasl.C_rx_success (id, secOpt) ->
+                        loop ()
+                    | Beep_sasl.C_rx_failed errorMsg ->
+                        jout#fail "Authentication Error: code=%d '%s'"
+                            errorMsg.C.M_error.code errorMsg.C.M_error.content
+                    | Beep_sasl.C_rx_error x ->
+                        do_putError_ x
+                and do_putError_ x =
+                    ctrlTx#put U.C_tx_abort >>= fun () ->
+                    topTx#put (`Error x)
+                in
+                let greetCmd = U.C_tx_greeting (U.M_greeting.default, []) in
+                ctrlTx#put greetCmd >>= fun () ->
+                start (loop ()) `Greeting
+
+            method private service_ topTx socket k =
+                let topTx = (topTx :> [ `Final | `Error of exn ] tx) in
+                P.L0.UM.create socket U.R_listener k >>=
+                    fun (ctrlRx, ctrlTx) ->
+                let ctrlRx = (ctrlRx :> U.control_rx_t rx) in
+                let ctrlTx = (ctrlTx :> U.control_tx_t tx) in
+                simplex >>= fun (srvRx, srvTx) ->
+                let srvRx = (srvRx :> P.id_t Beep_sasl.control_rx_t rx) in
+                Sasl_authenticator.start authenticator >>= fun authTxTx ->
+                let authTxTx =
+                    (authTxTx :> (P.id_t, P.credential_t)
+                    Sasl_authenticator.request_t tx)
+                in
+                let serviceObj = new service authTxTx srvTx in
+                let greetMsg = U.M_greeting.cons serviceObj#profiles in
+                let services = [ (serviceObj :> C.service) ] in
+                let greetCmd = U.C_tx_greeting (greetMsg, services) in
+                ctrlTx#put greetCmd >>= fun () ->
+                let rec loop () =
+                    guard begin
+                        ctrlRx#get do_ctrlRx_ >>= fun () ->
+                        srvRx#get do_srvRx_
+                    end
+                and do_ctrlRx_ event =
+                    match event with
+                    | U.C_rx_failure x -> do_ctrlRx_failure_ x
+                    | U.C_rx_greeting greetMsg -> do_ctrlRx_greeting_ greetMsg
+                    | U.C_rx_error errorMsg -> do_ctrlRx_error_ errorMsg
+                    | U.C_rx_close closeMsg -> do_ctrlRx_close_ closeMsg
+                    | U.C_rx_reset -> do_ctrlRx_reset_ ()
+                    | U.C_rx_final -> do_ctrlRx_final_ ()
+                and do_ctrlRx_failure_ x =
+                    topTx#put (`Error x)
+                and do_ctrlRx_greeting_ greetMsg =
+                    load >>= function
+                    | `Greeting ->
+                        if greetMsg <> U.M_greeting.default then
+                            jout#fail "SASL_loopback.core#service_: \
+                                do_ctrlRx_greeting_ unexpected content";
+                        store `Tuning >>= loop
+                    | `Tuning ->
+                        jout#fail "SASL_loopback.core#service_: \
+                            do_ctrlRx_greeting_ already tuning!"
+                and do_ctrlRx_error_ x =
+                    jout#fail "SASL_loopback.core#service_: \
+                        do_ctrlRx_error_ unimplemented!"
+                and do_ctrlRx_close_ x =
+                    jout#fail "SASL_loopback.core#service_: \
+                        do_ctrlRx_close_ unimplemented!"
+                and do_ctrlRx_reset_ x =
+                    self#service2_ topTx socket k
+                and do_ctrlRx_final_ x =
+                    jout#fail "SASL_loopback.core#service_: \
+                        do_ctrlRx_final_ unimplemented!"
+                and do_srvRx_ = function
+                    | Beep_sasl.C_rx_success (id, secOpt) ->
+                        loop ()
+                    | Beep_sasl.C_rx_failed errorMsg ->
+                        jout#fail "Authentication Error: code=%d '%s'"
+                            errorMsg.C.M_error.code errorMsg.C.M_error.content
+                    | Beep_sasl.C_rx_error x ->
+                        do_putError_ x
+                and do_putError_ x =
+                    ctrlTx#put U.C_tx_abort >>= fun () ->
+                    topTx#put (`Error x)
+                in
+                start (loop ()) `Greeting
+        end
+end
+
+module SASL_loopback_profile_tcp4_anonymous: SASL_Loopback_Profile_T = struct
+    module L0 = TCP4_loopback
+    
+    type id_t = [ `Id_anonymous of Sasl_anonymous.Id.t ]
+    type query_t = Sasl_anonymous.query_t
+    type credential_t = Sasl_anonymous.credential_t
+    
+    class supplicant =
+        let id = (Sasl_anonymous.Id.of_string "user@example.org") in
+        let idV = `Id_anonymous id in
+        object
+            inherit [id_t, query_t, credential_t] Sasl_supplicant.simple idV
+
+            method private query_ `Q_anonymous = `Cr_anonymous id
+        end
+    
+    class authenticator =
+        object
+            inherit [id_t, credential_t] Sasl_authenticator.simple
+
+            method private answer_ (`Cr_anonymous id) =
+                Sasl_authenticator.Accept (`Id_anonymous id)
+        end
+    
+    let sasl_clients = [ new Sasl_anonymous.client ]
+    let sasl_services = [ new Sasl_anonymous.service ]
+end
+
+module SASL_loopback_tcp4_anonymous =
+    SASL_loopback(SASL_loopback_profile_tcp4_anonymous)
+
+module T3 = struct
+    open Iom_reactor
+    open Cf_cmonad.Op
+    
+    module L = SASL_loopback_tcp4_anonymous
+    module U = Beep_transport
+
+    let obj = object
+        inherit L.core
+        
+        method private client2_ topTx socket k =
+            L.P.L0.UM.create socket U.R_initiator k >>= fun (ctrlRx, ctrlTx) ->
+            let ctrlRx = (ctrlRx :> U.control_rx_t rx) in
+            let ctrlTx = (ctrlTx :> U.control_tx_t tx) in
+            Foo_loopback.greet_ topTx ctrlRx ctrlTx U.R_initiator k
+        
+        method private service2_ topTx socket k =
+            L.P.L0.UM.create socket U.R_listener k >>= fun (ctrlRx, ctrlTx) ->
+            let ctrlRx = (ctrlRx :> U.control_rx_t rx) in
+            let ctrlTx = (ctrlTx :> U.control_tx_t tx) in
+            Foo_loopback.greet_ topTx ctrlRx ctrlTx U.R_listener k
+    end
+    
+    let test () =
+        obj#test ()
 end
 
 let main () =
     let tests = [
-        T1.test; T2.test;
+        T1.test; T2.test; T3.test
     ] in
     Printf.printf "1..%d\n" (List.length tests);
     flush stdout;