Commits

jhwoodyatt  committed 647c494

Initial submit of OCaml NAE BEEP Core.

  • Participants
  • Parent commits 9a8df9b

Comments (0)

Files changed (2)

File beep/beep_sasl.ml

+(*---------------------------------------------------------------------------*
+  IMPLEMENTATION  beep_sasl.ml
+
+  Copyright (c) 2004, James H. Woodyatt
+  All rights reserved.
+
+  Redistribution and use in source and binary forms, with or without
+  modification, are permitted provided that the following conditions
+  are met:
+
+    Redistributions of source code must retain the above copyright
+    notice, this list of conditions and the following disclaimer.
+
+    Redistributions in binary form must reproduce the above copyright
+    notice, this list of conditions and the following disclaimer in
+    the documentation and/or other materials provided with the
+    distribution
+
+  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+  OF THE POSSIBILITY OF SUCH DAMAGE. 
+ *---------------------------------------------------------------------------*)
+
+(*
+module J = Cf_journal
+*)
+
+(*---
+  NOTE: multiple profiles can be requested in a <start> message, and
+  each <profile> element *can* have the content produced by sending
+  the Sasl_mechanism.C_tx_prompt event to the mechanism.  A successful
+  response from the server would then be for one of the mechanisms, and
+  the others would then need to be canceled.  This would mean each
+  mechanism could send its own request to the supplicant, which could
+  technically choose to present credentials for a different identity in
+  each case.  The protocol allows this, but it's an open question
+  whether it's a good idea to support it.  It would be somewhat
+  difficult, because you'd have to count the number of supplicant
+  requests you send and gather up the responses until you have a match
+  for each one-- and that's before you can even send the <start>
+  message, since some mechanisms expect the client to send the first
+  <blob> element.
+  
+  Perhaps, a separate reactor is the way to provide this function when
+  the feature is actually required in an application.  It's pretty hairy
+  to implement.
+---*)
+
+module U = Beep_transport
+module C = Beep_channel
+module E = Beep_exchange
+module E_xml = Beep_xml_exchange
+module Err = Beep_error
+
+let xml_header_string_ = Cf_message.contents E.xml_header_text
+
+module M_blob = struct
+    open Cf_parser.Op
+    
+    type t = string * [ `Continue | `Complete | `Abort ]
+    
+    let initial_ = "", `Continue
+    
+    let invalid_ pos pair =
+        let event = Xml_event.T_element_start ("blob", [pair]), pos in
+        raise (Xml_parser.Invalid event)
+    
+    let parse =
+        let attr pos (data, _) (k, v as pair) =
+            let status =
+                match k with
+                | "status" ->
+                    begin
+                        match v with
+                        | "continue" -> `Continue
+                        | "complete" -> `Complete
+                        | "abort" -> `Abort
+                        | _ -> invalid_ pos pair
+                    end
+                | _ ->
+                    invalid_ pos pair
+            in
+            data, status
+        in
+        let content (_, status) =
+            Xml_parser.accumulated_character_data >>= fun msg ->
+            let z = Cf_message.to_seq msg in
+            let z = Mime_base64.D.transcode z in
+            try
+                ~:(Cf_seq.to_string z, status)
+            with
+            | 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_
+    
+    let emit pp (data, status) =
+        Format.pp_print_string pp xml_header_string_;
+        Format.pp_print_string pp begin
+            match status with
+            | `Continue -> "<blob";
+            | `Complete -> "<blob status='complete'"
+            | `Abort -> "<blob status='abort'"
+        end;
+        if String.length data = 0 then
+            Format.pp_print_string pp "/>"
+        else begin
+            Format.pp_print_char pp '>';
+            Format.pp_print_string pp (Mime_base64.E.atomic data);
+            Format.pp_print_string pp "</blob>"
+        end;
+        E.xml_header
+
+    let xml_factory_singleton_ = Xml_expat.parser_factory ()
+    
+    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)
+        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
+        Cf_message.contents msg
+end
+
+module P = struct
+    let header_processing = `H_leave
+    
+    module MSG = M_blob
+    module RPY = M_blob
+    module ERR = U.M_error
+    module ANS = E_xml.Null_entity
+end
+
+module Exchange = E_xml.Create(P)
+module SaslM = Sasl_mechanism
+
+open Iom_reactor
+open Cf_cmonad.Op
+
+type 'id event_t =
+    | V_success of 'id * Sasl_security.codec_t option
+    | V_failed of Beep_channel.M_error.t
+    | V_error of exn
+
+let x_bad_frame_type_ = Err.X Err.X_bad_frame_type
+let x_authentication_error_ = Err.X Err.X_authentication_error
+
+let rec client_exchange_ ?loc eventTx mechTx ctrlTx msg =
+    let eventTx = (eventTx :> 'id event_t tx) in
+    let mechTx = (mechTx :> SaslM.control_tx_t tx) in
+    let ctrlTx = (ctrlTx :> C.control_tx_t tx) in
+    object(self)
+        inherit Exchange.client msg ()
+        
+        method private cancel_ code event =
+            mechTx#put SaslM.C_tx_cancel >>= fun () ->
+            let ctrl = (C.M_close.cons ?loc code) in
+            ctrlTx#put (C.C_tx_close ctrl) >>= fun () ->
+            eventTx#put event
+        
+        method private rpy = function
+            | Cf_exnopt.X x ->
+                self#cancel_ Err.Std_code.general_syntax_error (V_error x)
+            | Cf_exnopt.U (text, status) ->
+                let msg = Cf_message.create text in
+                match status with
+                | `Continue ->
+                    mechTx#put (SaslM.C_tx_continue msg)
+                | `Complete ->
+                    mechTx#put (SaslM.C_tx_continue msg) >>= fun () ->
+                    mechTx#put SaslM.C_tx_final
+                | `Abort ->
+                    let code = Err.Std_code.parameter_syntax_error in
+                    let error = Err.X Err.X_authentication_error in
+                    self#cancel_ code (V_error error)
+        
+        method private err: U.M_error.t Cf_exnopt.t -> ('s, unit) t = function
+            | Cf_exnopt.X x ->
+                self#cancel_ Err.Std_code.general_syntax_error (V_error x)
+            | Cf_exnopt.U error ->
+                self#cancel_ Err.Std_code.success (V_failed error)
+        
+        method private frame_type_error_ () =
+            let code = Err.Std_code.general_syntax_error in
+            let error = V_error (Err.X Err.X_bad_frame_type) in
+            self#cancel_ code error
+        
+        method private ans _ = self#frame_type_error_ ()
+        method private nul = self#frame_type_error_ ()
+    end
+
+let service_exchange_ ?loc eventTx mechRx mechTx ctrlTx =
+    let eventTx = (eventTx :> 'id event_t tx) in
+    let mechRx = (mechRx :> 'id SaslM.control_rx_t rx) in
+    let mechTx = (mechTx :> SaslM.control_tx_t tx) in
+    let ctrlTx = (ctrlTx :> C.control_tx_t tx) in
+    object(self)
+        inherit Exchange.service ()
+        
+        method private error_ rspTx code event =
+            let rspTx = (rspTx :> 'rsp tx) in
+            mechTx#put SaslM.C_tx_cancel >>= fun () ->
+            eventTx#put event >>= fun () ->
+            rspTx#put (self#err (C.M_error.cons ?loc code))
+        
+        method private continue_ rspTx mechEvt =
+            let rspTx = (rspTx :> 'rsp tx) in
+            match mechEvt with
+            | SaslM.C_rx_prompt ->
+                rspTx#put (self#rpy ("", `Continue))
+            | SaslM.C_rx_continue msg ->
+                let msg = Cf_message.contents msg in
+                rspTx#put (self#rpy (msg, `Continue))
+            | SaslM.C_rx_done (id, secOpt, msg) ->
+                let msg = Cf_message.contents msg in
+                rspTx#put (self#rpy (msg, `Complete)) >>= fun () ->
+                ctrlTx#put C.C_tx_reset >>= fun () ->
+                eventTx#put (V_success (id, secOpt))
+            | SaslM.C_rx_error x ->
+                let code = Err.Std_code.authentication_failed in
+                self#error_ rspTx code (V_error x)
+
+        method private msg rspTx blobEvt =
+            let rspTx = (rspTx :> 'rsp tx) in
+            match blobEvt with
+            | Cf_exnopt.X x ->
+                let code = Err.Std_code.authentication_failed in
+                self#error_ rspTx code (V_error x)
+            | Cf_exnopt.U (msg, cmd) ->
+                let msg = Cf_message.create msg in
+                match cmd with
+                | `Continue ->
+                    mechTx#put (SaslM.C_tx_continue msg) >>= fun () ->
+                    guard (mechRx#get (self#continue_ rspTx))
+                | `Complete ->
+                    let code = Err.Std_code.parameter_syntax_error in
+                    let x = Err.X Err.X_authentication_error in
+                    self#error_ rspTx code (V_error x)
+                | `Abort ->
+                    mechTx#put SaslM.C_tx_cancel >>= fun () ->
+                    let code = Err.Std_code.success in
+                    let errorMsg = C.M_error.cons ?loc code in
+                    eventTx#put (V_failed errorMsg) >>= fun () ->
+                    rspTx#put (self#err errorMsg)
+    end
+
+let error_service_ ?loc code =
+    object(self)
+        inherit Exchange.service ()
+
+        method msg rspTx _ =
+            let rspTx = (rspTx :> 'x tx) in
+            let msg = C.M_error.cons ?loc code in
+            rspTx#put (self#err msg)
+    end
+
+module NS = Cf_rbtree.Set(String)
+module NM = Cf_rbtree.Map(String)
+
+let uri_prefix_ = "http://iana.org/beep/SASL/"
+
+let uri_prefix_length_ = (* String.length uri_prefix_ *) 25;;
+assert (String.length uri_prefix_ = uri_prefix_length_);;
+
+let to_mechanism_name_ { C.M_profile.uri = uri } =
+    let len = String.length uri in
+    if len <= uri_prefix_length_ then
+        None
+    else if String.sub uri 0 uri_prefix_length_ <> uri_prefix_ then
+        None
+    else
+        let len = len - uri_prefix_length_ in
+        Some (String.sub uri uri_prefix_length_ len)
+
+let to_mechanism_name_profile_ p =
+    match to_mechanism_name_ p with
+    | Some n -> Some (n, p)
+    | None -> None
+
+let to_mechanism_names_ s = Cf_seq.optmap to_mechanism_name_ (Cf_seq.of_list s)
+
+let rec select_mechanism_ cmap z =
+    match Lazy.force z with
+    | Cf_seq.Z ->
+        raise Not_found
+    | Cf_seq.P (hd, tl) ->
+        try NM.search hd cmap with Not_found -> select_mechanism_ cmap tl
+
+let client_ ?loc eventTx mechRx mechTx ctrlRx ctrlTx =
+    let eventTx = (eventTx :> 'id event_t tx) in
+    let ctrlRx = (ctrlRx :> C.control_rx_t rx) in
+    let ctrlTx = (ctrlTx :> C.control_tx_t tx) in
+    let mechRx = (mechRx :> 'id SaslM.control_rx_t rx) in
+    let mechTx = (mechTx :> SaslM.control_tx_t tx) in
+    let rec loop () =
+        guard begin
+            ctrlRx#get get_ctrlRx_ >>= fun () ->
+            mechRx#get get_mechRx_
+        end
+    and get_ctrlRx_ = function
+        | C.C_rx_exchange exch ->
+            let obj = error_service_ ?loc Err.Std_code.service_unavailable in
+            obj#link exch >>= loop
+        | C.C_rx_close closeMsg ->
+            let finished = ctrlTx#put C.C_tx_release in
+            if closeMsg.C.M_close.code = Err.Std_code.success then
+                finished
+            else
+                let errorMsg = {
+                    C.M_error.code = closeMsg.C.M_close.code;
+                    C.M_error.lang = closeMsg.C.M_close.lang;
+                    C.M_error.content = closeMsg.C.M_close.content;
+                } in
+                eventTx#put (V_failed errorMsg) >>= fun () ->
+                finished
+        | C.C_rx_error errorMsg ->
+            eventTx#put (V_failed errorMsg)
+        | C.C_rx_release ->
+            Cf_cmonad.return ()
+        | C.C_rx_abort ->
+            mechTx#put SaslM.C_tx_cancel
+    and get_mechRx_ = function
+        | SaslM.C_rx_prompt ->
+            do_continue_ ""
+        | SaslM.C_rx_continue msg ->
+            do_continue_ (Cf_message.contents msg)
+        | SaslM.C_rx_done (id, codecOpt, _) ->
+            eventTx#put (V_success (id, codecOpt)) >>= fun () ->
+            ctrlTx#put C.C_tx_reset
+        | SaslM.C_rx_error error ->
+            let closeMsg =
+                C.M_close.cons ?loc Err.Std_code.transaction_error
+            in
+            ctrlTx#put (C.C_tx_close closeMsg) >>= fun () ->
+            eventTx#put (V_error error) >>= loop
+    and do_continue_ msg =
+        let msg = msg, `Continue in
+        let obj = client_exchange_ ?loc eventTx mechTx ctrlTx msg in
+        obj#link >>= fun exch ->
+        ctrlTx#put (C.C_tx_exchange exch) >>= loop
+    in
+    start (loop ()) ()
+
+class ['id] client ~m ~g =
+    let m = (m :> 'id SaslM.client list) in
+    let gmap = NS.of_seq (to_mechanism_names_ g) in
+    let c =
+        try List.find (fun c -> NS.member c#name gmap) m with
+        | Not_found -> invalid_arg "Beep_sasl.client: empty mechanism list"
+    in
+    fun ?srv ?loc eventTx ->
+    let loc = (loc :> Beep_locale.t option) in
+    let eventTx = (eventTx :> 'id event_t tx) in
+    let uri = uri_prefix_ ^ c#name in
+    object(self:'self)
+        constraint 'self = #C.client
+        
+        val startMsg_ =
+            let profile = C.M_profile.cons ~uri "" in {
+                C.M_start.serverName = srv;
+                C.M_start.profiles = profile, [];
+            }
+    
+        method private error_ x profileTx =
+            let profileTx = (profileTx :> C.profile tx) in
+            eventTx#put (V_error x) >>= fun () ->
+            profileTx#put (new C.profile)
+    
+        method private cons_ mechEvt profileTx =
+            let profileTx = (profileTx :> C.profile tx) in
+            SaslM.start c >>= fun (mechRx, mechTx) ->
+            let mechRx = (mechRx :> 'id SaslM.control_rx_t rx) in
+            let mechTx = (mechTx :> SaslM.control_tx_t tx) in
+            mechTx#put mechEvt >>= fun () ->
+            let profile = object
+                inherit C.profile
+                method private control_ = client_ ?loc eventTx mechRx mechTx
+            end in
+            profileTx#put profile
+                
+        method private profile_ profileMsg profileTx =
+            let profileTx = (profileTx :> C.profile tx) in
+            if uri <> profileMsg.C.M_profile.uri then begin
+                self#error_ (Err.X Err.X_authentication_error) profileTx
+            end
+            else begin
+                match profileMsg.C.M_profile.content with
+                | "" ->
+                    self#cons_ SaslM.C_tx_prompt profileTx
+                | s ->
+                    match M_blob.of_string s with
+                    | Cf_exnopt.X x ->
+                        self#error_ x profileTx
+                    | Cf_exnopt.U (blob, cmd : M_blob.t) ->
+                        match cmd with
+                        | `Abort ->
+                            let x = Err.X Err.X_authentication_error in
+                            self#error_ x profileTx
+                        | `Continue ->
+                            let msg = Cf_message.create blob in
+                            self#cons_ (SaslM.C_tx_continue msg) profileTx
+                        | `Complete ->
+                            self#cons_ SaslM.C_tx_final profileTx
+            end
+
+        method connect startTx connectRx =
+            let startTx = (startTx :> C.M_start.t tx) in
+            let connectRx = (connectRx :> C.client_start_t rx) in
+            startTx#put startMsg_ >>= fun () ->
+            let rec loop () =
+                guard begin
+                    connectRx#get begin function
+                        | C.CS_profile (profileMsg, profileTx) ->
+                            self#profile_ profileMsg profileTx
+                        | C.CS_error errorMsg ->
+                            eventTx#put (V_failed errorMsg)
+                    end
+                end
+            in
+            start (loop ()) ()
+    end
+
+let service_ ?loc eventTx mechRx mechTx ctrlRx ctrlTx =
+    let loc = (loc :> Beep_locale.t option) in
+    let eventTx = (eventTx :> 'id event_t tx) in
+    let mechRx = (mechRx :> 'id SaslM.control_rx_t rx) in
+    let mechTx = (mechTx :> SaslM.control_tx_t tx) in
+    let ctrlRx = (ctrlRx :> C.control_rx_t rx) in
+    let ctrlTx = (ctrlTx :> C.control_tx_t tx) in
+    let rec loop () = guard (ctrlRx#get do_ctrlRx_)
+    and do_ctrlRx_ = function
+        | C.C_rx_exchange exch ->
+            let obj = service_exchange_ ?loc eventTx mechRx mechTx ctrlTx in
+            obj#link exch >>= loop
+        | C.C_rx_close closeMsg ->
+            ctrlTx#put C.C_tx_release
+        | C.C_rx_release
+        | C.C_rx_error _ ->
+            assert (not true);
+            Cf_cmonad.return ()
+        | C.C_rx_abort ->
+            mechTx#put SaslM.C_tx_cancel
+    in
+    start (loop ()) ()
+
+let compare_name_ name s =
+    not (String.compare s#name name <> 0)
+
+class ['id] service ~m ?loc eventTx =
+    let loc = (loc :> Beep_locale.t option) in
+    let eventTx = (eventTx :> 'id event_t tx) in
+    let doSrvRspError srvRspRx srvRspTx code =
+        let srvRspRx = (srvRspRx :> C.service_start_t rx) in
+        let srvRspTx = (srvRspTx :> C.service_start_t tx) in
+        let errorMsg = C.M_error.cons ?loc code in
+        srvRspTx#put (C.SS_error errorMsg) >>= fun () ->
+        Cf_cmonad.return (Some srvRspRx)
+    in
+    let doSrvRspProfile srvRspRx srvRspTx mechRx mechTx uri =
+        let srvRspRx = (srvRspRx :> C.service_start_t rx) in
+        let srvRspTx = (srvRspTx :> C.service_start_t tx) in
+        let mechRx = (mechRx :> 'id SaslM.control_rx_t rx) in
+        let mechTx = (mechTx :> SaslM.control_tx_t tx) in
+        let cons profileMsg =
+            let obj = object
+                inherit C.profile
+                method private control_ = service_ ?loc eventTx mechRx mechTx
+            end in
+            srvRspTx#put (C.SS_profile (profileMsg, obj))
+        in
+        let rec loop () = guard begin
+            mechRx#get begin function
+                | SaslM.C_rx_prompt ->
+                    cons (C.M_profile.cons ~uri "")
+                | SaslM.C_rx_continue msg ->
+                    let blob = Cf_message.contents msg in
+                    let blobMsg = M_blob.to_string (blob, `Continue) in
+                    cons (C.M_profile.cons ~uri blobMsg)
+                | SaslM.C_rx_done (id, secOpt, msg) ->
+                    let obj =
+                        object
+                            inherit C.profile
+                            method private control_ _ ctrlTx =
+                                let ctrlTx = (ctrlTx :> C.control_tx_t tx) in
+                                ctrlTx#put C.C_tx_reset
+                        end
+                    in
+                    let msg = Cf_message.contents msg in
+                    let blob = M_blob.to_string (msg, `Complete) in
+                    let profileMsg = C.M_profile.cons ~uri blob in
+                    eventTx#put (V_success (id, secOpt)) >>= fun () ->
+                    srvRspTx#put (C.SS_profile (profileMsg, obj))
+                | SaslM.C_rx_error x ->
+                    let code = Err.Std_code.authentication_failed in
+                    let errorMsg = C.M_error.cons ?loc code in
+                    srvRspTx#put (C.SS_error errorMsg) >>= fun () ->
+                    eventTx#put (V_failed errorMsg)
+            end
+        end in
+        start (loop ()) () >>= fun () ->
+        Cf_cmonad.return (Some srvRspRx)
+    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 ->
+                let hd, tl = startMsg.C.M_start.profiles in
+                let z = Cf_seq.of_list (hd :: tl) in
+                let z = Cf_seq.optmap to_mechanism_name_profile_ z in
+                let pMap = NM.of_seq z in
+                match List.filter (fun s -> NM.member s#name pMap) m with
+                | [] ->
+                    Cf_cmonad.return None
+                | s :: _ ->
+                    simplex >>= fun (srvRspRx, srvRspTx) ->
+                    let profileMsg = NM.search s#name pMap in
+                    let uri = profileMsg.C.M_profile.uri in
+                    match M_blob.of_string profileMsg.C.M_profile.content with
+                    | Cf_exnopt.X x ->
+                        eventTx#put (V_error x) >>= fun () ->
+                        let code = Err.Std_code.general_syntax_error in
+                        doSrvRspError srvRspRx srvRspTx code
+                    | Cf_exnopt.U (blob, cmd : M_blob.t) ->
+                        match cmd with
+                        | `Continue ->
+                            SaslM.start s >>= fun (mechRx, mechTx) ->
+                            let mechTx = (mechTx :> SaslM.control_tx_t tx) in
+                            let msg = Cf_message.create blob in
+                            mechTx#put (SaslM.C_tx_continue msg) >>= fun () ->
+                            doSrvRspProfile srvRspRx srvRspTx mechRx mechTx uri
+                        | `Complete ->
+                            SaslM.start s >>= fun (mechRx, mechTx) ->
+                            let mechTx = (mechTx :> SaslM.control_tx_t tx) in
+                            let msg = Cf_message.create blob in
+                            mechTx#put (SaslM.C_tx_continue msg) >>= fun () ->
+                            mechTx#put SaslM.C_tx_final >>= fun () ->
+                            doSrvRspProfile srvRspRx srvRspTx mechRx mechTx uri
+                        | `Abort ->
+                            let code = Err.Std_code.authentication_failed in
+                            doSrvRspError srvRspRx srvRspTx code
+
+        initializer
+            let m = (m :> 'id SaslM.service list) in
+            if m = [] then
+                invalid_arg "Beep_sasl.service: empty mechanism list"
+    end
+
+(*--- End of File [ beep_sasl.ml ] ---*)

File beep/beep_sasl.mli

+(*---------------------------------------------------------------------------*
+  INTERFACE  beep_sasl.mli
+
+  Copyright (c) 2004, James H. Woodyatt
+  All rights reserved.
+
+  Redistribution and use in source and binary forms, with or without
+  modification, are permitted provided that the following conditions
+  are met:
+
+    Redistributions of source code must retain the above copyright
+    notice, this list of conditions and the following disclaimer.
+
+    Redistributions in binary form must reproduce the above copyright
+    notice, this list of conditions and the following disclaimer in
+    the documentation and/or other materials provided with the
+    distribution
+
+  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+  OF THE POSSIBILITY OF SUCH DAMAGE. 
+ *---------------------------------------------------------------------------*)
+
+module M_blob: Beep_xml_exchange.Entity_T
+    with type t = string * [ `Continue | `Complete | `Abort ]
+
+module Exchange: Beep_xml_exchange.T
+    with module P.MSG = M_blob
+    and module P.RPY = M_blob
+    and module P.ERR = Beep_transport.M_error
+    and module P.ANS = Beep_xml_exchange.Null_entity
+
+open Iom_reactor
+
+type 'id event_t =
+    | V_success of 'id * Sasl_security.codec_t option
+    | V_failed of Beep_channel.M_error.t
+    | V_error of exn
+
+class ['id] client:
+    m:'id #Sasl_mechanism.client list -> g:Beep_channel.M_profile.t list ->
+    ?srv:string -> ?loc:#Beep_locale.t -> 'id event_t #tx ->
+    Beep_channel.client
+
+class ['id] service:
+    m:'id #Sasl_mechanism.service list -> ?loc:#Beep_locale.t ->
+    'id event_t #tx -> Beep_channel.service
+
+(*--- End of File [ beep_sasl.mli ] ---*)