Commits

jhwoodyatt  committed 42cfa20

Checkpoint. More progress on the SASL profile. Cancel semantics still
broken. Sigh.

  • Participants
  • Parent commits 779be6d
  • Branches PAGODA

Comments (0)

Files changed (3)

 
 + (Beep_transport, tcp): Add hooks for TLS tuning profile.
 
-+ (Beep_session): Remove M_reset from the mode_t type.
++ (Beep_sasl): Cancel semantics are broken.  If supplicant cancels, then
+    service MUST reset and wait for exchange to restart (or `Abort), and client
+    should restart the exchange on the same channel.  The supplicant MUST send
+    a Beep_channel.M_close.t and start a new client channel if the next
+    exchange needs to use a different mechanism.
 
-+ (Beep_session): Incomplete.
-
-+ No support for SASL or TLS tuning profiles.
++ No support for TLS tuning profile.
 
 # End of open issues

File beep/beep_sasl.ml

   OF THE POSSIBILITY OF SUCH DAMAGE. 
  *---------------------------------------------------------------------------*)
 
-(*
+(**)
 module J = Cf_journal
-*)
+(**)
 
 (*---
   NOTE: multiple profiles can be requested in a <start> message, and
 
 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 mechTx = (mechTx :> SaslM.client_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 () ->
+        method private abort_ code event =
+            mechTx#put `Abort >>= 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)
+                self#abort_ 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)
+                    mechTx#put (`Continue msg)
                 | `Complete ->
-                    mechTx#put (SaslM.C_tx_continue msg) >>= fun () ->
-                    mechTx#put SaslM.C_tx_final
+                    let msgOpt = match msg with [] -> None | _ -> Some msg in
+                    mechTx#put (`Final msgOpt)
                 | `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)
+                    self#abort_ 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)
+                self#abort_ Err.Std_code.general_syntax_error (V_error x)
             | Cf_exnopt.U error ->
-                self#cancel_ Err.Std_code.success (V_failed error)
+                self#abort_ 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
+            self#abort_ code error
         
         method private ans _ = self#frame_type_error_ ()
         method private nul = self#frame_type_error_ ()
 
 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 mechRx = (mechRx :> 'id SaslM.service_rx_t rx) in
+    let mechTx = (mechTx :> SaslM.service_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 () ->
+            mechTx#put `Abort >>= 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 ->
+            match (mechEvt : 'id SaslM.service_rx_t) with
+            | `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
+            | `Done (id, secOpt, msgOpt) ->
+                let msg =
+                    match msgOpt with
+                    | Some msg -> Cf_message.contents msg
+                    | None -> ""
+                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 ->
+            | `Error x ->
                 let code = Err.Std_code.authentication_failed in
                 self#error_ rspTx code (V_error x)
 
                 let msg = Cf_message.create msg in
                 match cmd with
                 | `Continue ->
-                    mechTx#put (SaslM.C_tx_continue msg) >>= fun () ->
+                    mechTx#put (`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 () ->
+                    mechTx#put `Cancel >>= fun () ->
                     let code = Err.Std_code.success in
                     let errorMsg = C.M_error.cons ?loc code in
                     eventTx#put (V_failed errorMsg) >>= fun () ->
     | 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 client_ ?loc ?closeRx eventTx mechRx mechTx ctrlRx ctrlTx =
+    let closeRx = match closeRx with None -> new rx null | Some rx -> rx in
+    let closeRx = (closeRx :> C.M_close.t rx) in
     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 mechRx = (mechRx :> 'id SaslM.client_rx_t rx) in
+    let mechTx = (mechTx :> SaslM.client_tx_t tx) in
     let rec loop () =
         guard begin
             ctrlRx#get get_ctrlRx_ >>= fun () ->
-            mechRx#get get_mechRx_
+            mechRx#get get_mechRx_ >>= fun () ->
+            closeRx#get get_closeRx_
         end
     and get_ctrlRx_ = function
         | C.C_rx_exchange exch ->
         | C.C_rx_release ->
             Cf_cmonad.return ()
         | C.C_rx_abort ->
-            mechTx#put SaslM.C_tx_cancel
+            mechTx#put `Abort
     and get_mechRx_ = function
-        | SaslM.C_rx_prompt ->
+        | `Continue msg ->
+            do_continue_ (Cf_message.contents msg)
+        | `Cancel ->
+            let msg = "", `Abort in
+            let obj = client_exchange_ ?loc eventTx mechTx ctrlTx msg in
+            obj#link >>= fun exch ->
+            ctrlTx#put (C.C_tx_exchange exch) >>= loop
+        | `Prompt ->
             do_continue_ ""
-        | SaslM.C_rx_continue msg ->
-            do_continue_ (Cf_message.contents msg)
-        | SaslM.C_rx_done (id, codecOpt, _) ->
+        | `Done (id, codecOpt) ->
             eventTx#put (V_success (id, codecOpt)) >>= fun () ->
             ctrlTx#put C.C_tx_reset
-        | SaslM.C_rx_error error ->
+        | `Error x ->
             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
+            eventTx#put (V_error x) >>= loop
+    and get_closeRx_ closeMsg =
+        ctrlTx#put (C.C_tx_close closeMsg) >>= loop
     and do_continue_ msg =
         let msg = msg, `Continue in
         let obj = client_exchange_ ?loc eventTx mechTx ctrlTx msg in
         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 ->
+    fun ?srv ?loc ?close eventTx ->
     let loc = (loc :> Beep_locale.t option) in
+    let close = (close :> C.M_close.t rx 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 =
+            
+        method private error_ x mechTx profileTx =
+            let mechTx = (mechTx :> SaslM.client_tx_t tx) in
             let profileTx = (profileTx :> C.profile tx) in
+            mechTx#put `Abort >>= fun () ->
             eventTx#put (V_error x) >>= fun () ->
             profileTx#put (new C.profile)
     
-        method private cons_ mechEvt profileTx =
+        method private cons_ 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 mechRx = (mechRx :> 'id SaslM.client_rx_t rx) in
+            let mechTx = (mechTx :> SaslM.client_tx_t tx) in
             let profile = object
                 inherit C.profile
-                method private control_ = client_ ?loc eventTx mechRx mechTx
+                method private control_ =
+                    let closeRx = close in
+                    client_ ?loc ?closeRx eventTx mechRx mechTx
             end in
             profileTx#put profile
                 
-        method private profile_ profileMsg profileTx =
+        method private profile_ profileMsg 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
             if uri <> profileMsg.C.M_profile.uri then begin
-                self#error_ (Err.X Err.X_authentication_error) profileTx
+                self#error_ (Err.X Err.X_authentication_error) mechTx profileTx
             end
             else begin
                 match profileMsg.C.M_profile.content with
                 | "" ->
-                    self#cons_ SaslM.C_tx_prompt profileTx
+                    self#cons_ profileTx
                 | s ->
                     match M_blob.of_string s with
                     | Cf_exnopt.X x ->
-                        self#error_ x profileTx
+                        self#error_ x mechTx 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
+                            self#error_ x mechTx profileTx
                         | `Continue ->
                             let msg = Cf_message.create blob in
-                            self#cons_ (SaslM.C_tx_continue msg) profileTx
+                            mechTx#put (`Continue msg) >>= fun () ->
+                            self#cons_ profileTx
                         | `Complete ->
-                            self#cons_ SaslM.C_tx_final profileTx
+                            let msgOpt =
+                                match blob with
+                                | "" -> None
+                                | _ -> Some (Cf_message.create blob)
+                            in
+                            mechTx#put (`Final msgOpt) >>= fun () ->
+                            self#cons_ 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 () ->
+            SaslM.start c >>= fun (mechRx, mechTx) ->
+            let mechRx = (mechRx :> 'id SaslM.client_rx_t rx) in
+            let mechTx = (mechTx :> SaslM.client_tx_t tx) in
             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
+                    connectRx#get do_connectRx_ >>= fun () ->
+                    mechRx#get do_mechRx_
                 end
+            and do_connectRx_ = function
+                | C.CS_profile (profileMsg, profileTx) ->
+                    self#profile_ profileMsg mechRx mechTx profileTx
+                | C.CS_error errorMsg ->
+                    mechTx#put `Abort >>= fun () ->
+                    eventTx#put (V_failed errorMsg)
+            and do_mechRx_ = function
+                | `Continue msg ->
+                    do_startMsg_ (Some msg)
+                | `Cancel
+                | `Prompt ->
+                    do_startMsg_ None
+                | `Error _
+                | `Done _ ->
+                    J.stdout#fail
+                        "Beep_sasl.client#connect/do_mechRx_: incomplete!"
+            and do_startMsg_ blobOpt =
+                let blobMsg =
+                    match blobOpt with
+                    | Some blob ->
+                        let blob = Cf_message.contents blob in
+                        M_blob.to_string (blob, `Continue)
+                    | None ->
+                        ""
+                in
+                let startMsg =
+                    let profile = C.M_profile.cons ~uri blobMsg in {
+                        C.M_start.serverName = srv;
+                        C.M_start.profiles = profile, [];
+                    }
+                in
+                startTx#put startMsg >>= loop
             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 mechRx = (mechRx :> 'id SaslM.service_rx_t rx) in
+    let mechTx = (mechTx :> SaslM.service_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_)
             assert (not true);
             Cf_cmonad.return ()
         | C.C_rx_abort ->
-            mechTx#put SaslM.C_tx_cancel
+            mechTx#put `Abort
     in
     start (loop ()) ()
 
     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 mechRx = (mechRx :> 'id SaslM.service_rx_t rx) in
+        let mechTx = (mechTx :> SaslM.service_tx_t tx) in
         let cons profileMsg =
             let obj = object
                 inherit C.profile
             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)
+        let rec loop () =
+            guard begin
+                mechRx#get do_mechRx_
             end
-        end in
+        and do_mechRx_ = function
+            | `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)
+            | `Done (id, secOpt, msgOpt) ->
+                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 =
+                    match msgOpt with
+                    | None -> ""
+                    | Some 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))
+            | `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)
+        in
         start (loop ()) () >>= fun () ->
         Cf_cmonad.return (Some srvRspRx)
     in
                         match cmd with
                         | `Continue ->
                             SaslM.start s >>= fun (mechRx, mechTx) ->
-                            let mechTx = (mechTx :> SaslM.control_tx_t tx) in
+                            let mechTx = (mechTx :> SaslM.service_tx_t tx) in
                             let msg = Cf_message.create blob in
-                            mechTx#put (SaslM.C_tx_continue msg) >>= fun () ->
+                            mechTx#put (`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 mechTx = (mechTx :> SaslM.service_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 () ->
+                            mechTx#put (`Continue msg) >>= fun () ->
                             doSrvRspProfile srvRspRx srvRspTx mechRx mechTx uri
                         | `Abort ->
                             let code = Err.Std_code.authentication_failed in

File beep/beep_sasl.mli

 
 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
+    ?srv:string -> ?loc:#Beep_locale.t -> ?close:Beep_channel.M_close.t #rx ->
+    'id event_t #tx -> Beep_channel.client
 
 class ['id] service:
     m:'id #Sasl_mechanism.service list -> ?loc:#Beep_locale.t ->