Commits

jhwoodyatt  committed 6963f34

Revise to use the new interface to the mechanism reactors. Add a more
complete loopback test for mechanisms. (Still needs work.)

  • Participants
  • Parent commits ef8eb64
  • Branches PAGODA

Comments (0)

Files changed (2)

File sasl/sasl_anonymous.ml

+(*---------------------------------------------------------------------------*
+  IMPLEMENTATION  sasl_anonymous.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
+*)
+
+open Cf_cmonad.Op
+
+module Id = struct
+    open Cf_parser.Op
+    open Cf_lexer.Op
+    open Mime_common
+        
+    type t =
+        | Null
+        | Address of string * string
+        | Token of string
+    
+    let emit pp = function
+        | Null ->
+            ()
+        | Address (local, domain) ->
+            Mime_emitter.addr_local pp local;
+            Format.pp_print_char pp '@';
+            Mime_emitter.addr_domain pp domain
+        | Token token ->
+            Format.pp_print_string pp token
+        
+    let parse () =
+        let mimeParser = object
+            inherit ['cursor, 'field] Mime_parser.t
+            method addr_spec = addr_spec_
+        end in
+        let email_ =
+            mimeParser#addr_spec >>= fun (loc, dom) ->
+            Cf_parser.fin >>= fun () ->
+            ~:(Address (loc, dom))
+        in
+        let ttext_ =
+            !+ begin
+                !^ begin
+                    function
+                    | '\032'..'\063' | '\065'..'\126' -> true
+                    | _ -> false
+                end
+            end
+        in
+        let tlimit_: int -> ('c, string) Cf_lexer.t = fun n s ->
+            if n > 255 then
+                None
+            else
+                let s = Cf_seq.first s in
+                Some (Cf_seq.to_string s, Lazy.lazy_from_val Cf_seq.Z)
+        in
+        let tlexer_ z = Cf_lexer.create !@[ ttext_ $@ tlimit_ ] z in
+        let token_ =
+            tlexer_ >>= fun s ->
+            Cf_parser.fin >>= fun () ->
+            ~:(Token s)
+        in
+        let null_ = Cf_parser.fin >>= fun () -> ~:Null in
+        fun s ->
+            Cf_parser.alt [ email_; token_; null_ ] s
+
+    let to_string v =
+        let b = Buffer.create 40 in
+        let pp = Format.formatter_of_buffer b in
+        emit pp v;
+        Format.pp_print_flush pp ();
+        Buffer.contents b
+    
+    let of_string =
+        let pz = lazy (parse ()) in
+        fun s ->
+            let p = Lazy.force pz in
+            let c = new Cf_lexer.cursor 0 in
+            match p (Cf_parser.X.weave ~c (Cf_seq.of_string s)) with
+            | None ->
+                invalid_arg "Sasl_anonymous.Id.of_string"
+            | Some (v, _) ->
+                v
+end
+
+module R = Iom_reactor
+module Mech = Sasl_mechanism
+module Auth = Sasl_authenticator
+module Supp = Sasl_supplicant
+module Sec = Sasl_security
+module Err = Sasl_error
+
+let name_ = "ANONYMOUS"
+
+let properties_ = {
+    Sec.p_flags = Sec.Flags.nil;
+    Sec.p_ssf = 0;
+}
+
+type query_t = [ `Q_anonymous ]
+type credential_t = [ `Cr_anonymous of Id.t ]
+
+class ['id] client suppTxTx =
+    let suppTxTx = (suppTxTx :> ('id, 'q, 'cr) Supp.request_t R.tx) in
+    object(self)
+        inherit ['identity] Mech.client_core ~name:name_ ~sec:properties_
+        
+        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
+                        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 (`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] Mech.service_core ~name:name_ ~sec:properties_
+        
+        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 () =
+                    R.guard begin
+                        ctrlRx#get do_ctrlRx_ >>= fun () ->
+                        authRx#get do_authRx_
+                    end
+                and do_ctrlRx_ event =
+                    R.load >>= fun state ->
+                    match event with
+                    | `Prompt ->
+                        put_error_ Err.X_mechanism_error
+                    | `Continue m ->
+                        if state = 0 then begin
+                            let s = Cf_message.contents m in
+                            match
+                                try Some (Id.of_string s)
+                                with Invalid_argument _ -> None
+                            with
+                            | None ->
+                                put_error_ Err.X_invalid_identity
+                            | Some cr ->
+                                let cr = `Cr_anonymous cr in
+                                let req = Auth.Request (cr, authTx) in
+                                authTxTx#put req >>= fun () ->
+                                R.store 1 >>= loop
+                        end
+                        else
+                            put_error_ Err.X_control_error
+                    | `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 (`Done (id, None, None))
+                    | Auth.Error x ->
+                        ctrlTx#put (`Error x)
+                and put_error_ e =
+                    ctrlTx#put (`Error (Err.X e))
+                in
+                R.start (loop ()) 0
+    end
+
+(*--- End of File [ sasl_anonymous.ml ] ---*)

File sasl/t/t_sasl.ml

+(*---------------------------------------------------------------------------*
+  IMPLEMENTATION  t_sasl.ml
+
+  Copyright (c) 2003-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 type X_tag = sig
+    val tag: string
+end
+
+module X_create(T: X_tag) = struct
+    let tag = Printf.sprintf "[%s] " T.tag
+
+    let printf fmt =
+        print_string tag;
+        Printf.printf fmt
+    
+    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
+    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
+        (*
+        simplex >>= fun (sigRx, sigTx) ->
+        signal ~n:Sys.sigint ~r:sigTx k >>= fun () ->
+        let sigRx = (sigRx :> e_signal_t rx) 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
+            | `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 () =
+    let tests = [
+        T1.test;
+    ] in
+    Printf.printf "1..%d\n" (List.length tests);
+    flush stdout;
+        
+    let test i f =
+        begin
+            try
+                f ();
+                Printf.printf "ok %d\n" i
+            with
+            | Failure(s) ->
+                Printf.printf "not ok %d (Failure \"%s\")\n" i s
+            | x ->
+                Printf.printf "not ok %d\n" i;
+                flush stdout;
+                raise x
+        end;
+        flush stdout;
+        succ i
+    in
+    let _ = List.fold_left test 1 tests in
+    exit 0
+;;
+
+main ();;
+
+(*--- End of File [ t_sasl.ml ] ---*)