Commits

Anonymous committed 6834377

Merging from PAGODA branch to top of tree.

  • Participants
  • Parent commits eaf787c

Comments (0)

Files changed (11)

 Open issues in development:
 
-+ (unimplemented): No code exists.
++ (t_sasl): Generalize the loopback test and reuse it in multiple tests.
+
++ (unimplemented): Need DIGEST and OTP mechanisms.
 
 # End of open issues

sasl/sasl_anonymous.ml

   OF THE POSSIBILITY OF SUCH DAMAGE. 
  *---------------------------------------------------------------------------*)
 
+(*
+module J = Cf_journal
+*)
+
 open Cf_cmonad.Op
 
 module Id = struct
 class ['id] client suppTxTx =
     let suppTxTx = (suppTxTx :> ('id, 'q, 'cr) Supp.request_t R.tx) in
     object(self)
-        inherit ['identity, [`Client]] Mech.core ~name:name_ ~sec:properties_
+        inherit ['identity] Mech.client_core ~name:name_ ~sec:properties_
         
-        method core:
-            's. Mech.control_tx_t R.rx -> 'identity Mech.control_rx_t R.tx ->
-            ('s, unit) R.t
-            = fun ctrlRx ctrlTx ->
-                let ctrlRx = (ctrlRx :> Mech.control_tx_t R.rx) in
-                let ctrlTx = (ctrlTx :> 'id Mech.control_rx_t R.tx) in
-                let rec loop () =
-                    R.load >>= fun state ->
-                    R.guard begin
-                        ctrlRx#get do_ctrlRx_ >>= fun () ->
-                        match state with
-                        | `Pend suppRx ->
-                            let suppRx = (suppRx :> ('id * 'cr) option R.rx) in
-                            suppRx#get do_suppRx_
-                        | _ ->
-                            Cf_cmonad.return ()
-                    end
-                and do_suppRx_ = function
-                    | None ->
-                        put_error_ Err.X_cancelled_by_user
-                    | Some (id, cr) ->
-                        match cr with
-                        | `Cr_anonymous cr ->
-                            R.store (`Fini id) >>= fun () ->
-                            let s = Id.to_string cr in
-                            let m = Cf_message.create s in
-                            ctrlTx#put (Mech.C_rx_continue m) >>= loop
-                        | _ ->
-                            put_error_ Err.X_supplicant_error
-                and do_ctrlRx_ event =
-                    R.load >>= fun state ->
-                    match state, event with
-                    | `Init, Mech.C_tx_prompt ->
-                        R.simplex >>= fun (suppRx, suppTx) ->
+        method core ctrlRx ctrlTx =
+            let ctrlRx = (ctrlRx :> Mech.client_tx_t R.rx) in
+            let ctrlTx = (ctrlTx :> 'id Mech.client_rx_t R.tx) in
+            let rec loop () =
+                R.load >>= fun state ->
+                R.guard begin
+                    ctrlRx#get do_ctrlRx_ >>= fun () ->
+                    match state with
+                    | `Pend suppRx ->
                         let suppRx = (suppRx :> ('id * 'cr) option R.rx) in
-                        R.store (`Pend suppRx) >>= fun () ->
-                        let req = Supp.Request (`Q_anonymous, suppTx) in
-                        suppTxTx#put req >>= loop
-                    | `Fini id, Mech.C_tx_final ->
-                        ctrlTx#put (Mech.C_rx_done (id, None, []))
-                    | _, Mech.C_tx_cancel ->
+                        suppRx#get do_suppRx_
+                    | _ ->
                         Cf_cmonad.return ()
-                    | _, _ ->
-                        put_error_ Err.X_control_error
-                and put_error_ e =
-                    ctrlTx#put (Mech.C_rx_error (Err.X e))
-                in
-                R.start (loop ()) `Init
+                end
+            and do_suppRx_ = function
+                | None ->
+                    ctrlTx#put `Cancel
+                | Some (id, cr) ->
+                    match cr with
+                    | `Cr_anonymous cr ->
+                        R.store (`Fini id) >>= fun () ->
+                        let s = Id.to_string cr in
+                        let m = Cf_message.create s in
+                        ctrlTx#put (`Continue m) >>= loop
+                    | _ ->
+                        put_error_ Err.X_supplicant_error
+            and do_ctrlRx_ event =
+                R.load >>= fun state ->
+                match state, event with
+                | `Fini id, `Final None -> ctrlTx#put (`Done (id, None))
+                | `Fini id, `Final _ -> put_error_ Err.X_mechanism_error
+                | _, `Abort -> Cf_cmonad.return ()
+                | _, _ -> put_error_ Err.X_control_error
+            and put_error_ e =
+                ctrlTx#put (`Error (Err.X e))
+            in
+            R.simplex >>= fun (suppRx, suppTx) ->
+            let suppRx = (suppRx :> ('id * 'cr) option R.rx) in
+            suppTxTx#put (Supp.Request (`Q_anonymous, suppTx)) >>= fun () ->
+            R.start (loop ()) (`Pend suppRx)
     end
 
 class ['id] service authTxTx =
     let authTxTx = (authTxTx :> ('id, 'cr) Auth.request_t R.tx) in
     object(self)
-        inherit ['identity, [`Service]] Mech.core ~name:name_ ~sec:properties_
+        inherit ['identity] Mech.service_core ~name:name_ ~sec:properties_
         
-        method core:
-            's. Mech.control_tx_t R.rx -> 'identity Mech.control_rx_t R.tx ->
-            ('s, unit) R.t
-            = fun ctrlRx ctrlTx ->
-                let ctrlRx = (ctrlRx :> Mech.control_tx_t R.rx) in
-                let ctrlTx = (ctrlTx :> 'identity Mech.control_rx_t R.tx) in
-                ctrlTx#put Mech.C_rx_prompt >>= fun () ->
+        method core ctrlRx ctrlTx =
+                let ctrlRx = (ctrlRx :> Mech.service_tx_t R.rx) in
+                let ctrlTx = (ctrlTx :> 'identity Mech.service_rx_t R.tx) in
                 R.simplex >>= fun (authRx, authTx) ->
                 let authRx = (authRx :> 'id Auth.answer_t R.rx) in
                 let rec loop () =
                 and do_ctrlRx_ event =
                     R.load >>= fun state ->
                     match event with
-                    | Mech.C_tx_prompt ->
-                        if state = 0 then
-                            ctrlTx#put Mech.C_rx_prompt >>= loop
-                        else
-                            put_error_ Err.X_control_error
-                    | Mech.C_tx_continue m ->
+                    | `Prompt ->
+                        put_error_ Err.X_mechanism_error
+                    | `Continue m ->
                         if state = 0 then begin
                             let s = Cf_message.contents m in
                             match
                         end
                         else
                             put_error_ Err.X_control_error
-                    | Mech.C_tx_cancel
-                    | Mech.C_tx_final ->
+                    | `Cancel ->
+                        R.store 0 >>= loop
+                    | `Abort ->
                         Cf_cmonad.return ()
                 and do_authRx_ event =
                     match event with
                     | Auth.Deny ->
                         put_error_ Err.X_access_denied
                     | Auth.Accept id ->
-                        ctrlTx#put (Mech.C_rx_done (id, None, []))
+                        ctrlTx#put (`Done (id, None, None))
                     | Auth.Error x ->
-                        ctrlTx#put (Mech.C_rx_error x)
+                        ctrlTx#put (`Error x)
                 and put_error_ e =
-                    ctrlTx#put (Mech.C_rx_error (Err.X e))
+                    ctrlTx#put (`Error (Err.X e))
                 in
                 R.start (loop ()) 0
     end

sasl/sasl_authenticator.ml

 
 class virtual ['id, 'cr] simple =
     object(self:('id, 'cr) #core)
-        method private virtual check_: 'cr -> 'id answer_t
+        method private virtual answer_: 'cr -> 'id answer_t
     
         method authenticator:
             's. ('id, 'cr) request_t R.rx -> ('s, unit) R.t =
                 let rec loop () =
                     R.guard (eventRx#get do_eventRx_)
                 and do_eventRx_ (Request (id, ansTx)) =
-                    ansTx#put (self#check_ id) >>= loop
+                    ansTx#put (self#answer_ id) >>= loop
                 in
                 R.start (loop ()) ()
     end
 
-class ['id, 'cr] stub answer =
-    object
-        inherit ['id, 'cr] simple
-        method private check_ _ = answer
-    end
-
 let start a =
     let a = (a :> ('id, 'cr) core) in
     R.simplex >>= fun (chRx, chTx) ->

sasl/sasl_authenticator.mli

 class virtual ['id, 'cr] simple:
     object
         inherit ['id, 'cr] core
-        method private virtual check_: 'cr -> 'id answer_t
-    end
-
-class ['id, 'cr] stub:
-    'id answer_t ->
-    object
-        inherit ['id, 'cr] simple
-
-        method private check_: 'cr -> 'id answer_t
+        method private virtual answer_: 'cr -> 'id answer_t
     end
 
 val start:

sasl/sasl_error.ml

     | X_control_error
     | X_supplicant_error
     | X_authenticator_error
-    | X_cancelled_by_user
     | X_no_sufficient_mechanism
     | X_access_denied
     | X_invalid_identity
+    | X_mechanism_error
+    | X_sequence_exhausted
 
 let to_string = function
     | X_control_error -> "control error"
     | X_supplicant_error -> "supplicant error"
     | X_authenticator_error -> "authenticator error"
-    | X_cancelled_by_user -> "cancelled by user"
     | X_no_sufficient_mechanism -> "no sufficient mechanism"
     | X_access_denied -> "access denied"
     | X_invalid_identity -> "invalid identity"
+    | X_mechanism_error -> "mechanism error"
+    | X_sequence_exhausted -> "sequence exhausted"
 
 exception X of t
 

sasl/sasl_error.mli

     | X_control_error
     | X_supplicant_error
     | X_authenticator_error
-    | X_cancelled_by_user
     | X_no_sufficient_mechanism
     | X_access_denied
     | X_invalid_identity
+    | X_mechanism_error
+    | X_sequence_exhausted
 
 val to_string: t -> string
 

sasl/sasl_mechanism.ml

 module Sec = Sasl_security
 module Err = Sasl_error
 
-type 'id control_rx_t =
-    | C_rx_prompt
-    | C_rx_continue of Cf_message.t
-    | C_rx_done of 'id * Sasl_security.codec_t option * Cf_message.t
-    | C_rx_error of exn
+type core_rx_t = [
+    | `Error of exn
+    | `Continue of Cf_message.t
+]
 
-type control_tx_t =
-    | C_tx_prompt
-    | C_tx_continue of Cf_message.t
-    | C_tx_cancel
-    | C_tx_final
+type 'id client_rx_t = [
+    | core_rx_t
+    | `Prompt
+    | `Cancel
+    | `Done of 'id * Sec.codec_t option
+]
 
-class virtual ['id, 'role] core ~name ~sec =
-    object(self)
-        constraint 'role = [< `Client | `Service ]
+type 'id service_rx_t = [
+    | core_rx_t
+    | `Done of 'id * Sec.codec_t option * Cf_message.t option
+]
 
+type core_tx_t = [
+    | `Continue of Cf_message.t
+    | `Abort
+]
+
+type client_tx_t = [
+    | core_tx_t
+    | `Final of Cf_message.t option
+]
+
+type service_tx_t = [
+    | core_tx_t
+    | `Prompt
+    | `Cancel
+]
+
+class virtual ['id, 'rx, 'tx] core ~name ~sec =
+    object        
         method name = (name : string)
         method security_properties = (sec : Sasl_security.properties_t)
 
         method virtual core:
-            's. control_tx_t R.rx -> 'id control_rx_t R.tx -> ('s, unit) R.t
+            's 'a 'b. ('tx #R.rx as 'a) -> ('rx #R.tx as 'b) -> ('s, unit) R.t
     end
 
-class type ['id, 'role] t =
+class virtual ['id] client_core = ['id, 'id client_rx_t, client_tx_t] core
+class virtual ['id] service_core = ['id, 'id service_rx_t, service_tx_t] core
+
+class type ['id, 'rx, 'tx] t =
     object
-        constraint 'role = [< `Client | `Service ]
-        inherit ['id, 'role] core
+        inherit ['id, 'rx, 'tx] core
 
         method core:
-            's. control_tx_t R.rx -> 'id control_rx_t R.tx -> ('s, unit) R.t
+            's 'a 'b. ('tx #Iom_reactor.rx as 'a) ->
+            ('rx #Iom_reactor.tx as 'b) -> ('s, unit) Iom_reactor.t
     end
 
-class type ['id] client = ['id, [`Client]] t
-class type ['id] service = ['id, [`Service]] t
+class type ['id] client = ['id, 'id client_rx_t, client_tx_t] t
+class type ['id] service = ['id, 'id service_rx_t, service_tx_t] t
 
 let start c =
-    let c = (c :> ('id, 'role) core) in
-    R.duplex >>= fun (ctrlIO, (ctrlRx, ctrlTx)) ->
+    let c = (c :> ('id, 'rx, 'tx) t) in
+    R.duplex >>= fun ((ctrlRx, ctrlTx), ctrlIO) ->
     c#core ctrlRx ctrlTx >>= fun () ->
     Cf_cmonad.return ctrlIO
 

sasl/sasl_mechanism.mli

   OF THE POSSIBILITY OF SUCH DAMAGE. 
  *---------------------------------------------------------------------------*)
 
-type 'id control_rx_t =
-    | C_rx_prompt
-    | C_rx_continue of Cf_message.t
-    | C_rx_done of 'id * Sasl_security.codec_t option * Cf_message.t
-    | C_rx_error of exn
+type core_rx_t = [
+    | `Error of exn
+    | `Continue of Cf_message.t
+]
 
-type control_tx_t =
-    | C_tx_prompt
-    | C_tx_continue of Cf_message.t
-    | C_tx_cancel
-    | C_tx_final
+type 'id client_rx_t = [
+    | core_rx_t
+    | `Prompt
+    | `Cancel
+    | `Done of 'id * Sasl_security.codec_t option
+]
 
-class virtual ['id, 'role] core:
+type 'id service_rx_t = [
+    | core_rx_t
+    | `Done of 'id * Sasl_security.codec_t option * Cf_message.t option
+]
+
+type core_tx_t = [
+    | `Continue of Cf_message.t
+    | `Abort
+]
+
+type client_tx_t = [
+    | core_tx_t
+    | `Final of Cf_message.t option
+]
+
+type service_tx_t = [
+    | core_tx_t
+    | `Prompt
+    | `Cancel
+]
+
+class virtual ['id, 'rx, 'tx] core:
     name:string -> sec:Sasl_security.properties_t ->
     object
-        constraint 'role = [< `Client | `Service ]
-        
         method name: string
         method security_properties: Sasl_security.properties_t
-        
+
         method virtual core:
-            's. control_tx_t Iom_reactor.rx ->
-            'id control_rx_t Iom_reactor.tx -> ('s, unit) Iom_reactor.t
+            's 'a 'b. ('tx #Iom_reactor.rx as 'a) ->
+            ('rx #Iom_reactor.tx as 'b) -> ('s, unit) Iom_reactor.t
     end
 
-class type ['id, 'role] t =
+class virtual ['id] client_core:
+    name:string -> sec:Sasl_security.properties_t ->
+    ['id, 'id client_rx_t, client_tx_t] core
+
+class virtual ['id] service_core:
+    name:string -> sec:Sasl_security.properties_t ->
+    ['id, 'id service_rx_t, service_tx_t] core
+
+class type ['id, 'rx, 'tx] t =
     object
-        constraint 'role = [< `Client | `Service ]
-        inherit ['id, 'role] core
+        inherit ['id, 'rx, 'tx] core
 
         method core:
-            's. control_tx_t Iom_reactor.rx ->
-            'id control_rx_t Iom_reactor.tx -> ('s, unit) Iom_reactor.t
+            's 'a 'b. ('tx #Iom_reactor.rx as 'a) ->
+            ('rx #Iom_reactor.tx as 'b) -> ('s, unit) Iom_reactor.t
     end
 
-class type ['id] client = ['id, [`Client]] t
-class type ['id] service = ['id, [`Service]] t
+class type ['id] client = ['id, 'id client_rx_t, client_tx_t] t
+class type ['id] service = ['id, 'id service_rx_t, service_tx_t] t
 
 val start:
-    ('id, 'role) #core ->
-    ('s, 'id control_rx_t Iom_reactor.rx *
-        control_tx_t Iom_reactor.tx) Iom_reactor.t
+    ('id, 'rx, 'tx) #t ->
+    ('s, 'rx Iom_reactor.rx * 'tx Iom_reactor.tx) Iom_reactor.t
 
 (*--- End of File [ sasl_mechanism.mli ] ---*)

sasl/sasl_supplicant.ml

 
 class virtual ['id, 'q, 'cr] simple id =
     object(self:('id, 'q, 'cr) #core)
-        method private virtual credential: 'q -> 'cr
+        method private virtual query_: 'q -> 'cr
 
         method supplicant:
             's. ('id, 'q, 'cr) request_t R.rx -> ('s, unit) R.t =
                     R.guard begin
                         reqRx#get begin fun (req : ('id, 'q, 'cr) request_t) ->
                             let Request (q, ansTx) = req in
-                            ansTx#put (Some (id, self#credential q)) >>= loop
+                            ansTx#put (Some (id, self#query_ q)) >>= loop
                         end
                     end
                 in

sasl/sasl_supplicant.mli

     'id ->
     object
         inherit ['id, 'q, 'cr] core
-        method private virtual credential: 'q -> 'cr
+        method private virtual query_: 'q -> 'cr
     end
 
 val start: ('id, 'q, 'cr) #core -> ('s, ('id, 'q, 'cr) request_t tx) t
   OF THE POSSIBILITY OF SUCH DAMAGE. 
  *---------------------------------------------------------------------------*)
 
+(*
 module type X_tag = sig
     val tag: string
 end
     let sprintf (fmt : ('a, unit, string) format) =
         Printf.sprintf (Obj.magic (tag ^ (Obj.magic fmt)))
 end
+*)
+
+(**)
+module J = Cf_journal
+(* let _ = J.stdout#setlimit `None *)
+(**)
 
 module T1 = struct
-    let test () = ()
+    open Iom_reactor
+    open Cf_cmonad.Op
+    
+    module Mech = Sasl_mechanism
+    module Supp = Sasl_supplicant
+    module Auth = Sasl_authenticator
+    module Anon = Sasl_anonymous
+
+    type id_t = Id of int
+    
+    class supp id =
+        object
+            inherit [id_t, Anon.query_t, Anon.credential_t] Supp.simple id
+            
+            method private query_ `Q_anonymous =
+                let Id n = id in
+                J.stdout#info "T1.supp#query_: Id %u" n;
+                `Cr_anonymous (Anon.Id.of_string (string_of_int n))
+        end
+    
+    class auth =
+        object
+            inherit [id_t, Anon.credential_t] Auth.simple
+
+            method private answer_ (`Cr_anonymous id) =
+                try
+                    let n = int_of_string (Anon.Id.to_string id) in
+                    J.stdout#info "T1.auth#answer_: Accept %u" n;
+                    Auth.Accept (Id n)
+                with
+                | _ ->
+                    J.stdout#warn "T1.auth#answer_: Deny";
+                    Auth.Deny
+        end
+
+    let reactor id k =
+        Supp.start (new supp id) >>= fun suppTx ->
+        let client = new Anon.client suppTx in
+        Mech.start (new Anon.client suppTx) >>= fun (cRx, cTx) ->
+        let cRx = (cRx :> id_t Mech.client_rx_t rx) in
+        let cTx = (cTx :> Mech.client_tx_t tx) in
+        Auth.start (new auth) >>= fun authTx ->
+        Mech.start (new Anon.service authTx) >>= fun (sRx, sTx) ->
+        let sRx = (sRx :> id_t Mech.service_rx_t rx) in
+        let sTx = (sTx :> Mech.service_tx_t tx) in
+        let rec loop () =
+            guard begin
+                cRx#get do_cRx_ >>= fun () ->
+                sRx#get do_sRx_ (* >>= fun () ->
+                sigRx#get do_sigRx_ *)
+            end
+        and do_cRx_ = function
+            | `Prompt ->
+                J.stdout#info "T1.reactor/do_cRx_: `Prompt";
+                sTx#put `Prompt >>= loop
+            | `Cancel ->
+                J.stdout#info "T1.reactor/do_cRx_: `Cancel";
+                sTx#put `Cancel >>= loop
+            | `Continue msg ->
+                J.stdout#info "T1.reactor/do_cRx_: `Continue";
+                sTx#put (`Continue msg) >>= loop
+            | `Done (id', secOpt) ->
+                do_complete_ id'
+            | `Error x ->
+                do_error_ x
+        and do_sRx_ = function
+            | `Continue msg ->
+                J.stdout#info "T1.reactor/do_sRx_: `Continue";
+                cTx#put (`Continue msg) >>= loop
+            | `Done (id', secOpt, msgOpt) ->
+                J.stdout#info "T1.reactor/do_sRx_: `Done";
+                cTx#put (`Final msgOpt) >>= fun () ->
+                do_complete_ id'
+            | `Error x ->
+                do_error_ x
+        and do_error_ = function
+            | Sasl_error.X error ->
+                let msg = Sasl_error.to_string error in
+                J.stdout#fail "T1.reactor/do_error_: Sasl_error '%s'" msg
+            | x ->
+                let msg = Printexc.to_string x in
+                J.stdout#fail "T1.reactor/do_error_: exn='%s'" msg
+        and do_complete_ id' =
+            if id <> id' then
+                J.stdout#fail "T1.reactor/do_cRx_: `Done (bad id)!";
+            load >>= fun n ->
+            J.stdout#info "T1.reactor/do_complete_: n=%u" n;
+            if n < 2 then
+                store (succ n) >>= loop
+            else
+                Cf_cmonad.return ()
+        in
+        J.stdout#info "T1.reactor: starting...";
+        start (loop ()) 0
+
+    let test = run (reactor (Id 0))
 end
 
 let main () =