Anonymous avatar Anonymous committed b46db0b

Checkpoint. Fix bugs in handling tuning resets. Implement better loopback
testing for BEEP sessions containing SASL negotiations.

Comments (0)

Files changed (11)

beep/beep_channel.ml

     end
 
 type service_start_t =
-    | SS_profile of M_profile.t * profile
+    | SS_profile of M_profile.t * (unit, unit) t option * profile rx
     | SS_error of M_error.t
 
 class type service =

beep/beep_channel.mli

     end
 
 type service_start_t =
-    | SS_profile of M_profile.t * profile
+    | SS_profile of M_profile.t * (unit, unit) t option * profile rx
     | SS_error of M_error.t
 
 class type service =

beep/beep_error.ml

     | X_entity_too_large -> "entity too large"
     | X_incomplete_entity_header _ -> "incomplete entity header"
     | X_invalid_entity_header -> "invalid entity header"
-    | X_unparsed_entity_body _ -> "unparsed entity body"
+    | X_unparsed_entity_body msg ->
+        Printf.sprintf "unparsed entity body:\n%s\n" (Cf_message.contents msg)
     | X_not_well_formed_xml pos ->
         let line = pos.Xml_event.pos_line_number in
         let column = pos.Xml_event.pos_column_number in

beep/beep_sasl.ml

   OF THE POSSIBILITY OF SUCH DAMAGE. 
  *---------------------------------------------------------------------------*)
 
-(**)
-module J = Cf_journal
-(**)
+(*
+let jout = Cf_journal.stdout
+*)
 
 (*---
   NOTE: multiple profiles can be requested in a <start> message, and
             | Not_found ->
                 Cf_parser.err (fun _ -> Err.X Err.X_authentication_error)
         in
-        let space = Xml_parser.S_preserve in
         fun _ ->
-            Xml_parser.validated_element
-                ~tag:"blob" ~attr ~content ~space initial_
+            Xml_parser.validated_element ~tag:"blob" ~attr ~content initial_
     
-    let emit pp (data, status) =
-        Format.pp_print_string pp xml_header_string_;
+    let emit_1_ ?(cdata = false) pp (data, status) =
+        if not cdata then
+            Format.pp_print_string pp xml_header_string_
+        else
+            Format.pp_print_string pp "<![CDATA[";
         Format.pp_print_string pp begin
             match status with
             | `Continue -> "<blob";
             Format.pp_print_string pp (Mime_base64.E.atomic data);
             Format.pp_print_string pp "</blob>"
         end;
+        if cdata then
+            Format.pp_print_string pp "]]>";
         E.xml_header
+    
+    let emit pp v = emit_1_ pp v
 
     let xml_factory_singleton_ = Xml_expat.parser_factory ()
     
+    let parse_1_ = E_xml.parse_entity (parse `H_leave)
+    
     let of_string s =
         let msg = Cf_message.create s in
         let z = Xml_event.stream xml_factory_singleton_ msg in
         try
-            match parse `H_leave z with
-            | Some (v, _) -> Cf_exnopt.U v
-            | None -> Cf_exnopt.X (Err.X Err.X_authentication_error)
+            match parse_1_ z with
+            | Some (v, _) ->
+                Cf_exnopt.U v
+            | None ->
+                Cf_exnopt.X (Err.X Err.X_authentication_error)
         with
         | Xml_parser.Invalid (_, pos) ->
             Cf_exnopt.X (Err.X (Err.X_invalid_xml pos))
     
-    let to_string blob =
-        let _, msg = Beep_entity_exchange.emit_aux ~f:emit blob in
+    let to_string ?cdata blob =
+        let _, msg = Beep_entity_exchange.emit_aux ~f:(emit_1_ ?cdata) blob in
+        (* strip trailing CRLF *)
+        let pos = Cf_message.length msg - 2 in
+        assert (pos > 0);
+        let msg = Cf_message.truncate ~pos msg in
         Cf_message.contents msg
 end
 
 
 let uri_prefix_ = "http://iana.org/beep/SASL/"
 
-let uri_prefix_length_ = (* String.length uri_prefix_ *) 25;;
+let uri_prefix_length_ = (* String.length uri_prefix_ *) 26;;
 assert (String.length uri_prefix_ = uri_prefix_length_);;
 
 let to_mechanism_name_ { C.M_profile.uri = uri } =
     | Cf_seq.P (hd, tl) ->
         try NM.search hd cmap with Not_found -> select_mechanism_ cmap tl
 
+let precompleted_ =
+    object
+        inherit C.profile
+
+        method tuning = true
+
+        method private control_ _ chTx =
+            let chTx = (chTx :> C.control_tx_t tx) in
+            chTx#put C.C_tx_reset
+    end
+
 let client_ ~c ?loc ctrlRx ctrlTx mechRx mechTx chRx chTx =
     let c = (c :> 'id SaslM.client) in
     let ctrlRx = (ctrlRx :> client_tx_t rx) in
         | `Prompt ->
             do_continue_ "" mechTx
         | `Done (id, codecOpt) ->
-            ctrlTx#put (C_rx_success (id, codecOpt)) >>= fun () ->
-            chTx#put C.C_tx_reset
+            chTx#put C.C_tx_reset >>= fun () ->
+            ctrlTx#put (C_rx_success (id, codecOpt))
         | `Error x ->
             let closeMsg =
                 C.M_close.cons ?loc Err.Std_code.transaction_error
     let mechTx = (mechTx :> SaslM.client_tx_t tx) in
     start (loop ()) (`Pending (mechRx, mechTx))
 
-class ['id] client ~m ~g =
+class client ~m ~g =
     let m = (m :> 'id SaslM.client list) in
     let gmap = NS.of_seq (to_mechanism_names_ g) in
     let c =
     let uri = uri_prefix_ ^ c#name in
     object(self:'self)
         constraint 'self = #C.client
-            
+                    
         method private error_ x mechTx profileTx =
             let mechTx = (mechTx :> SaslM.client_tx_t tx) in
             let profileTx = (profileTx :> C.profile tx) in
             ctrlTx#put (C_rx_error x) >>= fun () ->
             profileTx#put (new C.profile)
     
-        method private cons_ profileTx =
-            let profileTx = (profileTx :> C.profile tx) in
-            SaslM.start c >>= fun (mechRx, mechTx) ->
+        method private cons_ mechRx mechTx profileTx =
             let mechRx = (mechRx :> 'id SaslM.client_rx_t rx) in
             let mechTx = (mechTx :> SaslM.client_tx_t tx) in
+            let profileTx = (profileTx :> C.profile tx) in
             let profile = object
                 inherit C.profile
+                method tuning = true
                 method private control_ =
                     client_ ~c ?loc ctrlRx ctrlTx mechRx mechTx
             end in
             else begin
                 match profileMsg.C.M_profile.content with
                 | "" ->
-                    self#cons_ profileTx
+                    self#cons_ mechRx mechTx profileTx
                 | s ->
                     match M_blob.of_string s with
                     | Cf_exnopt.X x ->
                         | `Continue ->
                             let msg = Cf_message.create blob in
                             mechTx#put (`Continue msg) >>= fun () ->
-                            self#cons_ profileTx
+                            self#cons_ mechRx mechTx profileTx
                         | `Complete ->
                             let msgOpt =
                                 match blob with
                                 | _ -> Some (Cf_message.create blob)
                             in
                             mechTx#put (`Final msgOpt) >>= fun () ->
-                            self#cons_ profileTx
+                            self#cons_ mechRx mechTx profileTx
             end
         
         method connect startTx connectRx =
                     match blobOpt with
                     | Some blob ->
                         let blob = Cf_message.contents blob in
-                        M_blob.to_string (blob, `Continue)
+                        M_blob.to_string ~cdata:true (blob, `Continue)
                     | None ->
                         ""
                 in
 let compare_name_ name s =
     not (String.compare s#name name <> 0)
 
-class ['id] service ~m ?loc ctrlTx =
+class service ~m ?loc ctrlTx =
     let loc = (loc :> Beep_locale.t option) in
     let ctrlTx = (ctrlTx :> 'id control_rx_t tx) in
     let doSrvRspError srvRspRx srvRspTx code =
         let mechRx = (mechRx :> 'id SaslM.service_rx_t rx) in
         let mechTx = (mechTx :> SaslM.service_tx_t tx) in
         let cons profileMsg =
+            simplex >>= fun (profRx, profTx) ->
+            let profRx = (profRx :> C.profile rx) in
+            let profTx = (profTx :> C.profile tx) in
             let obj = object
                 inherit C.profile
+                method tuning = true
                 method private control_ = service_ ?loc ctrlTx mechRx mechTx
             end in
-            srvRspTx#put (C.SS_profile (profileMsg, obj))
+            let syncOpt = Some (profTx#put obj) in
+            srvRspTx#put (C.SS_profile (profileMsg, syncOpt, profRx))
         in
         let rec loop () =
             guard begin
         and do_mechRx_ = function
             | `Continue msg ->
                 let blob = Cf_message.contents msg in
-                let blobMsg = M_blob.to_string (blob, `Continue) in
+                let blobMsg = M_blob.to_string ~cdata:true (blob, `Continue) in
                 cons (C.M_profile.cons ~uri blobMsg)
             | `Done (id, secOpt, msgOpt) ->
-                let obj =
-                    object
-                        inherit C.profile
-                        method private control_ _ chTx =
-                            let chTx = (chTx :> C.control_tx_t tx) in
-                            chTx#put C.C_tx_reset
-                    end
-                in
                 let msg =
                     match msgOpt with
                     | None -> ""
                     | Some msg -> Cf_message.contents msg
                 in
-                let blob = M_blob.to_string (msg, `Complete) in
+                let blob = M_blob.to_string ~cdata:true (msg, `Complete) in
                 let profileMsg = C.M_profile.cons ~uri blob in
                 ctrlTx#put (C_rx_success (id, secOpt)) >>= fun () ->
-                srvRspTx#put (C.SS_profile (profileMsg, obj))
+                simplex >>= fun (profRx, profTx) ->
+                let profRx = (profRx :> C.profile rx) in
+                let profTx = (profTx :> C.profile tx) in
+                let syncOpt = Some (profTx#put precompleted_) in
+                srvRspTx#put (C.SS_profile (profileMsg, syncOpt, profRx))
             | `Error x ->
                 let code = Err.Std_code.authentication_failed in
                 let errorMsg = C.M_error.cons ?loc code in
     in
     object(self:'self)
         constraint 'self = #C.service
-
+        
         method accept:
             's. C.M_start.t -> ('s, C.service_start_t rx option) t =
             fun startMsg ->
                         doSrvRspError srvRspRx srvRspTx code
                     | Cf_exnopt.U (blob, cmd : M_blob.t) ->
                         match cmd with
+                        | `Complete ->
+                            let code = Err.Std_code.parameter_syntax_error in
+                            doSrvRspError srvRspRx srvRspTx code
                         | `Continue ->
                             SaslM.start s >>= fun (mechRx, mechTx) ->
                             let mechTx = (mechTx :> SaslM.service_tx_t tx) in
                             let msg = Cf_message.create blob in
                             mechTx#put (`Continue msg) >>= fun () ->
                             doSrvRspProfile srvRspRx srvRspTx mechRx mechTx uri
-                        | `Complete ->
-                            SaslM.start s >>= fun (mechRx, mechTx) ->
-                            let mechTx = (mechTx :> SaslM.service_tx_t tx) in
-                            let msg = Cf_message.create blob in
-                            mechTx#put (`Continue msg) >>= fun () ->
-                            doSrvRspProfile srvRspRx srvRspTx mechRx mechTx uri
                         | `Abort ->
                             let code = Err.Std_code.authentication_failed in
                             doSrvRspError srvRspRx srvRspTx code
+        
+        method profiles =
+            List.map begin fun s ->
+                let uri = uri_prefix_ ^ s#name in C.M_profile.cons ~uri ""
+            end m
 
         initializer
             let m = (m :> 'id SaslM.service list) in

beep/beep_sasl.mli

     | C_tx_close of Beep_channel.M_close.t
     | C_tx_restart
 
-class ['id] client:
+class client:
     m:'id #Sasl_mechanism.client list -> g:Beep_channel.M_profile.t list ->
     ?srv:string -> ?loc:#Beep_locale.t -> client_tx_t #rx ->
     'id control_rx_t #tx -> Beep_channel.client
 
-class ['id] service:
+class service:
     m:'id #Sasl_mechanism.service list -> ?loc:#Beep_locale.t ->
-    'id control_rx_t #tx -> Beep_channel.service
+    'id control_rx_t #tx ->
+    object
+        inherit Beep_channel.service
+        
+        method profiles: Beep_channel.M_profile.t list
+    end
 
 (*--- End of File [ beep_sasl.mli ] ---*)

beep/beep_tcp_mapping.ml

  *---------------------------------------------------------------------------*)
 
 (*
+let jout = Cf_journal.stdout
+*)
+
+(*
 module type X_tag = sig
     val tag: string
 end
     (*--- Process BEEP transport mapping event: M_tx_unlink ---*)
     and do_mapRx_unlink_ () =
         load >>= fun s ->
-        assert (N32_map.empty s.s_rlMap_);
+        (* assert (N32_map.empty s.s_rlMap_); *)
         match s.s_txVariant_ with
         | S_ready ->
             assert (N32_map.empty s.s_seqHdrMap_);
             assert (N32_map.empty s.s_fhQMap_);
             fdTx#put IO.IO_tx_unlink >>= loop
-            (* done processing *)
         | S_blocked
         | S_pending ->
             store {
         | hd :: tl ->
             (*
             X.printf "(RX) %s\n" (F_tcp.header_to_string hd);
+            (* X.printf "(RX) %s" (Cf_message.contents (F_tcp.emit hd)); *)
             flush stdout;
             *)
             match hd with
                 do_idleRx_fhQQ_ fhQQ
             | Some ({ F.h_data = frame; F.h_ack = ack }, fhQ) ->
                 (*
-                X.printf "(TX) %s\n" (F.header_to_string frame);
+                (* X.printf "(TX) %s\n" (F.header_to_string frame); *)
+                X.printf "(TX) %s" (Cf_message.contents (F_tcp.emit frame));
                 flush stdout;
                 *)
                 fdTx#put (IO.IO_tx_data (F.emit frame)) >>= fun () ->
                 s_seqHdrMap_ = N32_map.nil;
                 s_fhQMap_ = N32_map.nil;
             } >>= loop
+        | Cf_seq.Z when s.s_txVariant_ = S_unlinking ->
+            fdTx#put IO.IO_tx_unlink >>= loop
         | Cf_seq.Z ->
             assert (s.s_txVariant_ = S_pending);
             store {

beep/beep_transport.ml

  *---------------------------------------------------------------------------*)
 
 (*
+let jout = Cf_journal.stdout
+*)
+
+(*
 module type X_tag = sig
     val tag: string
 end
 module X = X_create(struct let tag = "Beep_transport" end)
 *)
 
-(**)
-module J = Cf_journal
-(**)
-
 open Iom_reactor
 open Cf_cmonad.Op
 
                 ~tag:"profile" ~attr ~content ~space initial_
     
     let emit pp x =
+        Format.pp_open_vbox pp 2;
         Format.pp_print_string pp "<profile uri='";
         Format.pp_print_string pp x.uri;
         Format.pp_print_char pp '\'';
             | E_none ->
                 ()
         end;
-        if x.content = "" then
-            Format.pp_print_string pp "/>"
+        if x.content = "" then begin
+            Format.pp_print_string pp "/>";
+            Format.pp_close_box pp ()
+        end
         else begin
             Format.pp_print_char pp '>';
+            Format.pp_print_cut pp ();
             Format.pp_print_string pp x.content;
+            Format.pp_close_box pp ();
+            Format.pp_print_cut pp ();
             Format.pp_print_string pp "</profile>"
         end
 end
 
     let emit pp x =
         Format.pp_print_string pp xml_header_string_;
+        Format.pp_print_flush pp ();
         E_profile.emit pp x;
         E.xml_header
 end
                 Format.pp_print_string pp s;
                 Format.pp_print_char pp '\'';
         end;
-        let hd, tl = x.profiles in
         Format.pp_print_char pp '>';
         List.iter begin fun profile ->
             Format.pp_print_cut pp ();
             E_profile.emit pp profile;
-        end (hd :: tl);
+        end (let hd, tl = x.profiles in hd :: tl);
         Format.pp_close_box pp ();
         Format.pp_print_cut pp ();
         Format.pp_print_string pp "</start>";
         in
         let content header obj =
             ?* begin
+                Xml_parser.optional_whitespace >>= fun () ->
                 E_profile.parse header >>= fun profile ->
                 if profile.E_profile.content <> "" then
                     Xml_parser.invalid
                 else
                     ~:profile
             end >>= fun profiles ->
+            Xml_parser.optional_whitespace >>= fun () ->
             ~:{ obj with profiles = profiles }
         in
-        let space = Xml_parser.S_preserve in
         fun header ->
             let content = content header in
             Xml_parser.validated_element 
-                ~tag:"greeting" ~attr ~content ~space default
+                ~tag:"greeting" ~attr ~content default
     
     let emit pp x =
         Format.pp_open_vbox pp 2;
             Format.pp_print_string pp "</greeting>"
         end;
         E.xml_header
+    
+    let cons ?(features = []) ?(localize = []) profiles = {
+        features = features;
+        localize = localize;
+        profiles = profiles;
+    }
 end
 
 module E_request = struct
 module E_reply = struct
     open Cf_parser.Op
     
-    type t = Profile of E_profile.t | Ok of (unit, unit) Iom_reactor.t option
+    type t =
+        | Profile of E_profile.t * (unit, unit) Iom_reactor.t option
+        | Ok of (unit, unit) Iom_reactor.t option
     
     let parse h = assert false  (* never called *)
     
     let emit pp = function
-        | Profile p -> M_profile.emit pp p
+        | Profile (p, _) -> M_profile.emit pp p
         | Ok _ -> M_ok.emit pp ()
 end
 
             upTx#put (`Fail (Err.X Err.X_bad_frame_type))
     end
 
+type s_rxq_entry_msg_t =
+    | Rxq_ERR of M_error.t
+    | Rxq_RPY of E_reply.t
+
 class union_service_exchange (dnRx, upTx) =
     let dnRx = (dnRx :> 'dn rx) in
     let upTx = (upTx :> 'up tx) in
             let f dnRpy =
                 dnTx#put begin
                     match dnRpy with
-                    | `RPY (E_reply.Ok sync as v) -> self#rpy ?sync v
-                    | `RPY v -> self#rpy v
-                    | `ERR v -> self#err v
+                    | Rxq_RPY (E_reply.Ok sync as v) ->
+                        self#rpy ?sync v
+                    | Rxq_RPY (E_reply.Profile (_, sync) as v) ->
+                        self#rpy ?sync v
+                    | Rxq_ERR v ->
+                        self#err v
                 end
             in
             guard (dnRx#get f)
     | Sv_close_tx of N32_set.t
     | Sv_close_rx of N32_set.t option
 
-type s_rxq_entry_msg_t = [ `ERR of M_error.t | `RPY of E_reply.t ]
-
 type s_rxq_entry_t =
     | C0_rx_close of int32 * s_rxq_entry_msg_t tx
-    | C0_rx_start0 of
-        int32 * s_rxq_entry_msg_t tx * C.service_start_t rx
-    | C0_rx_start1 of
-        int32 * s_rxq_entry_msg_t tx * C.M_profile.t * C.profile
+    | C0_rx_start0 of int32 * s_rxq_entry_msg_t tx * C.service_start_t rx
+    | C0_rx_start1 of int32 * C.profile rx
+    | C0_rx_start2 of int32 * C.profile
     | C0_rx_union of E_xml_union.P.MSG.t Cf_exnopt.t rx * s_rxq_entry_msg_t tx
 
 type s_txq_entry_start_t =
 
 let cons_errorMsg_ s code =
     let loc = s.s_locale_ in
-    `ERR {
+    Rxq_ERR {
         C.M_error.code = code;
         C.M_error.lang = loc#lang;
         C.M_error.content = loc#content code;
             | C0_rx_union (srvRx, srvTx) ->
                 get_c0SrvRx_ s srvRx srvTx
             | C0_rx_start0 (n, srvTx, srvRspRx) ->
-                get_c0SrvRspRx_ s n srvTx srvRspRx
-            | C0_rx_start1 _
+                get_c0SrvRspRx0_ s n srvTx srvRspRx
+            | C0_rx_start1 (n, objRx) ->
+                get_c0SrvRspRx1_ s n objRx
+            | C0_rx_start2 _
             | C0_rx_close _ ->
                 Cf_cmonad.return ()
     
             Cf_cmonad.return ()
         | S_online s ->
             match Cf_deque.B.pop s.s_rxQ_ with
-            | Some (C0_rx_start1 (n, srvTx, profileMsg, obj), rxQ) ->
-                srvTx#put (`RPY (E_reply.Profile profileMsg)) >>= fun () ->
+            | Some (C0_rx_start2 (n, obj), rxQ) ->
                 simplex >>= fun (dnRx, dnTx) ->
                 let muxIO = dnRx, upTx in
                 let cMap = N32_map.replace (n, dnTx) s.s_cMap_ in
         begin
             match Cf_deque.B.pop s.s_rxQ_ with
             | Some (C0_rx_close (n', srvTx), tl) when n = n' ->
-                srvTx#put (`ERR errorMsg) >>= fun () ->
+                srvTx#put (Rxq_ERR errorMsg) >>= fun () ->
                 Cf_cmonad.return tl
             | _ ->
                 assert (not true);
             begin
                 match Cf_deque.B.pop s.s_rxQ_ with
                 | Some (C0_rx_close (n', srvTx), tl) when n = n' ->
-                    srvTx#put (`RPY (E_reply.Ok None)) >>= fun () ->
+                    srvTx#put (Rxq_RPY (E_reply.Ok None)) >>= fun () ->
                     Cf_cmonad.return tl
                 | _ ->
                     assert (not true);
     (*--- Process session event: Up_reset ---*)
     and do_upRx_reset_ s n =
         assert (match s.s_variant_ with Sv_tuning _ -> true | _ -> false);
-        let s = { s with s_cMap_ = N32_map.delete n s.s_cMap_ } in
+        let s = {
+            s with
+            s_cMap_ = N32_map.delete n s.s_cMap_;
+            s_variant_ = Sv_unlinking;
+        } in
         store (S_online s) >>= fun () ->
         do_abort_channels_ () >>= fun () ->
         mapTx#put M_tx_unlink >>= loop
                 match event with
                 | C.C_rx_close _
                 | C.C_rx_error _
-                | C.C_rx_release
-                | C.C_rx_abort ->
+                | C.C_rx_release ->
                     assert (not true);
                     Cf_cmonad.return ()
+                | C.C_rx_abort ->
+                    loop ()
                 | C.C_rx_exchange exch ->
                     duplex >>= fun (srvIO, (srvRx, srvTx)) ->
                     let srv = new union_service_exchange srvIO in
                 match Cf_deque.B.pop s.s_rxQ_ with
                 | Some (C0_rx_close (n, srvTx), tl) ->
                     assert (n = Int32.zero);
-                    srvTx#put (`ERR errorMsg) >>= fun () ->
+                    srvTx#put (Rxq_ERR errorMsg) >>= fun () ->
                     Cf_cmonad.return tl
                 | _ ->
                     assert (not true);
                         new tx null
                 in
                 let sync = upTx#put (Up_sync Int32.zero) in
-                srvTx#put (`RPY (E_reply.Ok (Some sync))) >>= loop
+                srvTx#put (Rxq_RPY (E_reply.Ok (Some sync))) >>= loop
             end
             else
                 loop ()
         end
 
     (*--- Get response from service ---*)
-    and get_c0SrvRspRx_ s n srvTx srvRspRx =
+    and get_c0SrvRspRx0_ s n srvTx srvRspRx =
         let srvRspRx = (srvRspRx :> C.service_start_t rx) in
         let srvTx = (srvTx :> 'c0srvtx tx) in
         srvRspRx#get begin function
-            | C.SS_profile (profileMsg, obj) ->
-                mapTx#put (M_tx_start n) >>= fun () ->
-                let rxOp = C0_rx_start1 (n, srvTx, profileMsg, obj) in
+            | C.SS_profile (profileMsg, synOpt, objRx) ->
+                let rpy = Rxq_RPY (E_reply.Profile (profileMsg, synOpt)) in
+                srvTx#put rpy >>= fun () ->
+                let rxOp = C0_rx_start1 (n, objRx) in
                 let rxQ = Cf_deque.B.push rxOp s.s_rxQ_ in
-                let sv = if obj#tuning then Sv_tuning n else Sv_ready in
-                let s = { s with s_rxQ_ = rxQ; s_variant_ = sv; } in
+                let s = { s with s_rxQ_ = rxQ } in
                 store (S_online s) >>= loop
            | C.SS_error errorMsg ->
-                srvTx#put (`ERR errorMsg) >>= fun () ->
+                srvTx#put (Rxq_ERR errorMsg) >>= fun () ->
                 store (S_online s) >>= loop
         end
 
+    (*--- Get profile object from service ---*)
+    and get_c0SrvRspRx1_ s n objRx =
+        let objRx = (objRx :> C.profile rx) in
+        objRx#get begin fun obj ->
+            mapTx#put (M_tx_start n) >>= fun () ->
+            let rxOp =  C0_rx_start2 (n, obj) in
+            let rxQ = Cf_deque.B.push rxOp s.s_rxQ_ in
+            let sv = if obj#tuning then Sv_tuning n else Sv_ready in
+            let s = { s with s_rxQ_ = rxQ; s_variant_ = sv; } in
+            store (S_online s) >>= loop
+        end
+
     (*--- Get message for management channel ---*)
     and get_c0SrvRx_ s srvRx srvTx =
         let srvRx = (srvRx :> 'c0srvrx rx) in
         let srvTx = (srvTx :> 'c0srvtx tx) in
         match s.s_variant_ with
         | Sv_close_tx _ ->
-            srvTx#put (`RPY (E_reply.Ok None)) >>= loop
+            srvTx#put (Rxq_RPY (E_reply.Ok None)) >>= loop
         | Sv_close_rx _
         | Sv_unlinking ->
             assert (not true);

beep/beep_transport.mli

     }
     
     val default: t
+    
+    val cons:
+        ?features:string list -> ?localize:string list ->
+        Beep_channel.M_profile.t list -> t
 end
 
 module M_error: Beep_xml_exchange.Entity_T with type t = Beep_channel.M_error.t

beep/beep_xml_exchange.ml

   OF THE POSSIBILITY OF SUCH DAMAGE. 
  *---------------------------------------------------------------------------*)
 
-(**)
+(*
 module type X_tag = sig
     val tag: string
 end
 end
 
 module X = X_create(struct let tag = "Beep_xml_exchange" end)
-(**)
+*)
+
+(*
+let jout = Cf_journal.stdout
+*)
 
 module type Entity_T = sig
     type t
     | x ->
         Cf_exnopt.X x
 
+let parse_entity = P_aux.xml_entity_body
+
 module Create(P: Profile_T) = struct
     open Cf_cmonad.Op
     open Iom_reactor

beep/beep_xml_exchange.mli

     f:(Beep_exchange.header_t -> 'a Xml_parser.t) -> Beep_exchange.header_t ->
     Cf_message.t -> 'a Cf_exnopt.t
 
+val parse_entity: 'a Xml_parser.t -> 'a Xml_parser.t
+
 (*--- End of File [ beep_xml_exchange.mli ] ---*)
 (* let gc = Gc.get () in gc.Gc.verbose <- 0x91; Gc.set gc;; *)
 
 (**)
-module J = Cf_journal
+let jout = Cf_journal.stdout;;
+jout#setlimit `None;;
 (**)
 
 (*
             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 ->
-                            J.stdout#fail
+                            jout#fail
                                 "client#reactor: incomplete! [C_rx_close]";
                         | C.C_rx_error errorMsg ->
-                            J.stdout#fail
+                            jout#fail
                                 "client#reactor: incomplete! [C_rx_error]";
                         | C.C_rx_release ->
                             doneTx#put ()
                         | C.C_rx_abort ->
-                            J.stdout#fail
+                            jout#fail
                                 "client#reactor: incomplete! [C_rx_abort]";
                     end
                 in
                             | C.CS_profile (_, profileTx) ->
                                 profileTx#put (self :> C.profile)
                             | C.CS_error errorMsg ->
-                                J.stdout#fail "client#connect: incomplete!"
+                                jout#fail "client#connect: incomplete!"
                         end
                     end
                 in
                         | C.C_rx_close closeMsg ->
                             ctrlTx#put C.C_tx_release
                         | _ ->
-                            J.stdout#fail "service#reactor: incomplete!"
+                            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 ->
-                J.stdout#fail "client_/get_ctrlRx_: incomplete! [C_rx_close]"
+                jout#fail "client_/get_ctrlRx_: incomplete! [C_rx_close]"
             | U.C_rx_reset ->
-                J.stdout#fail "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 ->
-                J.stdout#fail "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
-                    J.stdout#fail "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 ->
-                J.stdout#fail "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
-
-    let exchange_ topTx role textPair socket 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
-                    J.stdout#fail "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"
-                end
-            end
-        end in
-        start (loop ()) `Init
-
-    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 test () =
-        for i = 1 to 3 do test_aux i done
 end
 
 module type Loopback_Profile_T = sig
         | `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 'b 'c 'x.
-                (([< `Final | `Error of exn ] as 'x) #Iom_reactor.tx as 'a) ->
-                (Beep_transport.control_rx_t #Iom_reactor.rx as 'b) ->
-                (Beep_transport.control_tx_t #Iom_reactor.tx as 'c) ->
-                ('s, unit) Iom_reactor.t
+                '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 'b 'c 'x.
-                (([< `Final | `Error of exn ] as 'x) #Iom_reactor.tx as 'a) ->
-                (Beep_transport.control_rx_t #Iom_reactor.rx as 'b) ->
-                (Beep_transport.control_tx_t #Iom_reactor.tx as 'c) ->
-                ('s, unit) Iom_reactor.t
+                '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) ->
-                Socket.address_t -> Iom_reactor.kernel_t ->
+                UM.S.address_t -> Iom_reactor.kernel_t ->
                 ('s, unit) Iom_reactor.t
 
             method private listener_:
 
     type top_event_t = [
         | `Error of exn
-        | `Listen of Socket.address_t
-        | `Connect of Socket.t
+        | `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
+        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 (guard ()) ()
 
-    let client_ topTx ctrlRx ctrlTx =
-        J.stdout#fail "Loopback.client_: unimplemented!"
-
-    let server_ topTx ctrlRx ctrlTx =
-        J.stdout#fail "Loopback.server_: unimplemented!"
+    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 'b 'c 'x.
-                (([< `Final | `Error of exn ] as 'x) #tx as 'a) ->
-                (U.control_rx_t #rx as 'b) -> (U.control_tx_t #tx as 'c) ->
-                ('s, unit) t
+                '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 'b 'c 'x.
-                (([< `Final | `Error of exn ] as 'x) #tx as 'a) ->
-                (U.control_rx_t #rx as 'b) -> (U.control_tx_t #tx as 'c) ->
-                ('s, unit) t
+                '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) -> Socket.address_t ->
-                kernel_t -> ('s, unit) t =
-                fun topTx addr k ->
-                    let topTx = (topTx :> top_event_t tx) in
-                    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 (guard ()) ()
-
+                '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 =
-                fun 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 ()) ()
+                listener_
 
             method private reactor_:
                 's. kernel_t -> ('s, unit) t =
                         load >>= function
                         | `Init ->
                             store `Connecting >>= fun () ->
-                            UM.create socket U.R_listener k >>=
-                            fun (ctrlRx, ctrlTx) ->
-                            self#client_ topTx ctrlRx ctrlTx >>= loop
+                            self#client_ topTx socket k >>= loop
                         | `Connecting ->
                             store (`Receiving 2) >>= fun () ->
-                            UM.create socket U.R_initiator k >>=
-                            fun (ctrlRx, ctrlTx) ->
-                            self#service_ topTx ctrlRx ctrlTx >>= loop
+                            self#service_ topTx socket k >>= loop
                         | _ ->
                             assert (not true);
                             Cf_cmonad.return ()
                 try
                     run self#reactor_ ();
                     if not okay_ then
-                        J.stdout#fail "loopback: reactor completed early.";
+                        jout#fail "loopback: reactor completed early.";
                 with
                 | Unix.Unix_error (error, fname, arg) ->
                     let error = Unix.error_message error in
-                    J.stdout#fail
+                    jout#fail
                         "Unix error \"%s\" in %s(%s).\n" error fname arg
                 | Sasl_error.X error ->
-                    J.stdout#fail
+                    jout#fail
                         "SASL error \"%s\"" (Sasl_error.to_string error)
                 | Beep_error.X error ->
-                    J.stdout#fail
+                    jout#fail
                         "BEEP error \"%s\"" (Beep_error.to_string error)
                 | x ->
                     raise x
 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 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 TCP6_loopback.core
+        inherit L.core
         
-        method private client_ topTx ctrlRx ctrlTx =
-            J.stdout#fail "T3.client_: unimplemented!"
+        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 service_ topTx ctrlRx ctrlTx =
-            J.stdout#fail "T3.service_: unimplemented!"
+        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; T3.obj#test
+        T1.test; T2.test; T3.test
     ] in
     Printf.printf "1..%d\n" (List.length tests);
     flush stdout;
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.