1# Written by Scott Hardin for the OpenXPKI Project 2010
2# Copyright (c) 2010 by the OpenXPKI Project
3
4package OpenXPKI::Test::QA::More;
5use Test::More;
6use OpenXPKI::Server::Workflow::WFObject::WFArray;
7use OpenXPKI::Client;
8use Data::Dumper;
9use Class::Std;
10
11{
12    use strict;
13    use warnings;
14    use Carp;
15
16    # don't 'use' Test::More because we override it's methods
17    #    require Test::More;
18
19    # Storage for object attributes
20    my %user_of : ATTR( get => 'user', set => 'user' );
21    my %password : ATTR( get => 'password', set => 'password' );
22    my %socketfile :
23        ATTR(get => 'socketfile', set => 'socketfile', init_arg => 'socketfile' );
24    my %realm : ATTR(get => 'realm', set => 'realm', init_arg => 'realm' );
25    my %stack : ATTR(get => 'stack', set => 'stack' );
26    my %wfid : ATTR(get => 'wfid', set => 'wfid' );
27    my %wftype : ATTR(get => 'wftype', set => 'wftype' );
28    my %client : ATTR(get => 'client', set => 'client' );
29    my %msg : ATTR(get => 'msg', set => 'msg');
30    my %verbose : ATTR(get => 'verbose', set => 'verbose');
31
32    # Handle initialization
33    #    sub BUILD {
34    #        my ( $self, $id, $args ) = @_;
35    #    }
36
37    ############################################################
38    # TEST METHODS
39    ############################################################
40
41   # Basically, the *_ok, *_nok, *_is, etc. all behave in a
42   # similar way -- they call the underlying method and wrap
43   # the response into an ok(), etc.
44   #
45   # The AUTOMETHOD creates a one-size-fits-all solution for this.
46   #
47   # There is, however, one caveat. In order for AUTOMETHOD to
48   # know which parameters are to be passed to the wrapped method,
49   # they are passed in an anonymous array as the first parameter.
50   #
51   # <method>_ok( [ <params for method> ], 'name of test' );
52   #
53   # <method>_is( [ <params for method> ], <expected value>, 'name of test' );
54   #
55
56    sub AUTOMETHOD {
57        my $self     = shift;
58        my $ident    = shift;
59        my $params   = shift;
60        my $testname = shift;
61        my $subname  = $_;
62        my ( $base, $action ) = $subname =~ m/\A (.+)_(.+?) \z/xms
63            or return;
64
65        # check that we support the test action
66        $action =~ m/\A (ok|nok|is|isnt) \z/xms
67            or return;
68
69        # check that we support the underlying method
70        $self->can($base)
71            or return;
72
73        $testname ||= 'Running ' . $base;
74
75        # methods that take 2 params
76        if ( $action =~ /^(ok|nok)$/ ) {
77            my $result = $self->$base( @{$params} );
78            my $ret = $self->$action( $result, $testname );
79            return sub { return $ret }
80        }
81        # @Fixme: Implement ok/nok and add like
82        return;
83
84    }
85
86    sub connect_ok {
87        my $self   = shift;
88        my %params = @_;
89
90        my $testname = 'Connect to server';
91        if ( exists $params{testname} ) {
92            $testname = $params{testname};
93            delete $params{testname};
94        }
95
96        my $ret = $self->connect(%params);
97        return $self->ok( $ret, $testname );
98    }
99
100    sub create_ok {
101        my ( $self, $wftype, $params, $testname ) = @_;
102        $testname ||= 'Creating workflow ' . $wftype;
103        my $ret = $self->create( $wftype, $params );
104        $self->ok( $ret, $testname );
105        return $ret;
106    }
107
108    sub create_nok {
109        my ( $self, $wftype, $params, $testname ) = @_;
110        $testname ||= 'Creating workflow ' . $wftype;
111        my $result = $self->create( $wftype, $params );
112        my $ret = $self->ok( ( not $result ), $testname );
113        return $ret;
114    }
115
116    sub execute_ok {
117        my ( $self, $action, $params, $testname ) = @_;
118        $testname ||= 'Executing action ' . $action;
119        return $self->ok( scalar( $self->execute( $action, $params ) ),
120            $testname );
121    }
122    sub execute_nok {
123        my ( $self, $action, $params, $testname ) = @_;
124        $testname ||= 'Executing action ' . $action;
125        my $result = scalar $self->execute( $action, $params );
126        $result = ($result)?0:1;
127
128        return $self->ok( $result,$testname );
129    }
130
131    sub param_is {
132        my ( $self, $name, $expected, $testname ) = @_;
133        $testname ||= 'Fetching parameter ' . $name;
134        return $self->is( $self->param($name), $expected, $testname );
135    }
136
137    sub param_isnt {
138        my ( $self, $name, $expected, $testname ) = @_;
139        $testname ||= 'Fetching parameter ' . $name;
140        return $self->isnt( $self->param($name), $expected, $testname );
141    }
142
143    sub param_like {
144        my ( $self, $name, $expected, $testname ) = @_;
145        $testname ||= 'Fetching parameter ' . $name;
146        return $self->like( $self->param($name), $expected, $testname );
147    }
148
149
150    sub state_is {
151        my ( $self, $state, $testname ) = @_;
152        $testname ||= 'Expecting state ' . $state;
153        my $currstate = $self->state();
154
155        if ( not defined $currstate ) {
156            $currstate = '<undef>';
157        }
158
159        if ( not defined $state ) {
160            $state = '<undef>';
161        }
162
163        if ( $self->get_verbose ) {
164            $self->diag("\tstate=$state");
165            $self->diag("\ttestname=$testname");
166            $self->diag("\tcurrstate=$currstate");
167        }
168        return $self->is( $currstate, $state, $testname );
169    }
170
171    sub error_is {
172        my ( $self, $expected, $testname ) = @_;
173        $testname ||= 'Checking API message error';
174        my $error = $self->error();
175        $error ||= '';#avoid undef
176        return $self->is($error , $expected, $testname );
177    }
178
179    ############################################################
180    # HELPER METHODS
181    ############################################################
182    sub login {
183        my $self   = shift;
184        my $client = $self->get_client;
185        my $user   = $self->get_user;
186        my $pass   = $self->get_password;
187        my $realm  = $self->get_realm;
188        my $msg;
189
190        $client->init_session();
191
192        if ($realm) {
193            $msg = $client->send_receive_service_msg( 'GET_PKI_REALM',
194                { PKI_REALM => $realm } );
195            $self->set_msg($msg);
196            if ( $self->error ) {
197                $self->diag(
198                    "Login failed (get pki realm $realm): " . Dumper $msg);
199                return;
200            }
201            $msg = $client->send_receive_service_msg( 'PING', );
202            $self->set_msg($msg);
203            if ( $self->error ) {
204                $self->diag( "Login failed (ping): " . Dumper $msg);
205                return;
206            }
207        }
208
209        if ($user) {
210            my $stack = $self->get_stack || 'Testing';
211            $msg
212                = $client->send_receive_service_msg(
213                'GET_AUTHENTICATION_STACK',
214                { 'AUTHENTICATION_STACK' => $stack, },
215                );
216            $self->set_msg($msg);
217            if ( $self->error ) {
218                $self->diag(
219                    "Login failed (stack selection): " . Dumper $msg);
220                return;
221            }
222
223            $msg = $client->send_receive_service_msg(
224                'GET_PASSWD_LOGIN',
225                {   'LOGIN'  => $user,
226                    'PASSWD' => $pass,
227                },
228            );
229            $self->set_msg($msg);
230            if ( $self->error ) {
231                $self->diag( "Login failed: " . Dumper $msg);
232                return;
233            }
234        }
235        else {
236            my $stack = $self->get_stack || 'Anonymous';
237            $msg
238                = $client->send_receive_service_msg(
239                'GET_AUTHENTICATION_STACK',
240                { 'AUTHENTICATION_STACK' => $stack, },
241                );
242            $self->set_msg($msg);
243            if ( $self->error ) {
244                $self->diag(
245                    "Login failed (stack selection): " . Dumper $msg);
246                return;
247            }
248        }
249
250        return 1;
251    }
252
253    sub connect {
254        my $self   = shift;
255        my %params = @_;
256        foreach my $k ( keys %params ) {
257            if ( not $k =~ m/^(user|password|socketfile|realm|stack)$/ ) {
258                croak "Invalid parameter '$k' to connect";
259            }
260        }
261
262        foreach my $k (qw( user password socketfile realm stack )) {
263            if ( exists $params{$k} ) {
264                my $accessor = 'set_' . $k;
265                $self->$accessor( $params{$k} );
266            }
267        }
268
269        my $c = OpenXPKI::Client->new(
270            {   TIMEOUT    => 100,
271                SOCKETFILE => $self->get_socketfile
272            }
273        );
274        if ( not $c ) {
275            croak "Unable to create OpenXPKI::Client instance: $@";
276        }
277
278        $self->set_client($c);
279
280        if ( $self->get_user ) {
281            $self->login(
282                {   CLIENT   => $c,
283                    USER     => $self->get_user,
284                    PASSWORD => $self->get_password,
285                    REALM    => $self->get_realm,
286                    STACK    => $self->get_stack,
287                }
288            ) or croak "Login as ", $self->get_user(), " failed: $@";
289        }
290        else {
291            $self->login( { CLIENT => $c, REALM => $self->get_realm } )
292                or croak "Login as anonymous failed: $@";
293        }
294        $self->set_msg(undef);
295        return $self;
296    }
297
298    sub command {
299
300        my ( $self, $name ) = @_;
301        my $client = $self->get_client;
302        my $command = shift;
303        my $params = shift;
304
305        my $msg = $client->send_receive_service_msg( $command , $params );
306
307        $self->set_msg($msg);
308
309        if ( $self->error ) {
310            $@ = 'Error getting workflow info: ' . Dumper($msg);
311            return sprintf('ERROR %s',$self->error);
312        }
313
314        return $msg->{PARAMS};
315    }
316
317
318
319    sub create {
320        my ( $self, $wftype, $params ) = @_;
321        my $client = $self->get_client;
322        $self->set_wftype($wftype);
323
324        my $msg
325            = $client->send_receive_command_msg( 'create_workflow_instance',
326            { PARAMS => $params, WORKFLOW => $wftype },
327            );
328
329        $self->diag(
330            "Command create_workflow_instance returned MSG: " . Dumper($msg) )
331            if $self->get_verbose;
332        $self->set_msg($msg);
333        $self->set_wfid( $msg->{PARAMS}->{WORKFLOW}->{ID} );
334        if ( $self->error ) {
335
336            #            $self->diag(" RETURNING ERROR ");
337            $@
338                = 'Error creating workflow '
339                . $wftype
340                . ' - MSG: '
341                . Dumper($msg);
342            return;
343        }
344        else {
345            return $self;
346        }
347    }
348
349    sub execute {
350        my ( $self, $action, $params ) = @_;
351        my $msg;
352        my $client = $self->get_client;
353        my $wftype = $self->get_wftype;
354        my $wfid   = $self->get_wfid;
355
356        if ( not defined $params ) {
357            $params = {};
358        }
359
360        croak("Unable to exec action '$action' on closed connection")
361            unless defined $client;
362
363        $msg = $client->send_receive_command_msg(
364            'execute_workflow_activity',
365            {   'ID'       => $wfid,
366                'WORKFLOW' => $wftype,
367                'ACTIVITY' => $action,
368                'PARAMS'   => $params,
369            },
370        );
371        $self->set_msg($msg);
372        $self->diag( "Command $action returned MSG: " . Dumper($msg) )
373            if $self->get_verbose;
374        if ( $self->error ) {
375            $@ = 'Error executing ' . $action . ': ' . Dumper($msg);
376            return;
377        }
378        return $self;
379    }
380
381    sub runcmd {
382
383        my ( $self, $action, $params ) = @_;
384        my $msg;
385        my $client = $self->get_client;
386
387        if ( not defined $params ) {
388            $params = {};
389        }
390
391        croak("Unable to exec action '$action' on closed connection")
392            unless defined $client;
393
394        $msg = $client->send_receive_command_msg(
395            $action, $params
396        );
397        $self->set_msg($msg);
398        $self->diag( "Command $action returned MSG: " . Dumper($msg) )
399            if $self->get_verbose;
400        if ( $self->error ) {
401            $@ = 'Error executing ' . $action . ': ' . Dumper($msg);
402            return;
403        }
404        return $self;
405
406    }
407
408    sub runcmd_ok {
409        my ( $self, $action, $params, $testname ) = @_;
410        $testname ||= 'Executing command ' . $action;
411        return $self->ok( scalar( $self->runcmd( $action, $params ) ),
412            $testname );
413    }
414
415    sub param {
416        my ( $self, $name ) = @_;
417        my $wfid   = $self->get_wfid;
418        my $client = $self->get_client;
419        my $msg    = $self->get_msg;
420
421        if ( not $msg ) {
422            $msg = $client->send_receive_command_msg( 'get_workflow_info',
423                { ID => $wfid } );
424        }
425
426        $self->set_msg($msg);
427
428
429        if ( $self->error ) {
430            $@ = 'Error getting workflow info: ' . Dumper($msg);
431            return sprintf('ERROR %s',$self->error);
432        }
433
434       #        $self->diag(
435       #            "context keys: "
436       #                . join( ', ',
437       #                sort keys %{ $msg->{PARAMS}->{WORKFLOW}->{CONTEXT} } )
438       #        );
439
440        my $val = (defined $msg->{PARAMS}->{WORKFLOW}->{CONTEXT}->{$name})?$msg->{PARAMS}->{WORKFLOW}->{CONTEXT}->{$name}:'UNDEFINED';
441        return $val;
442    }
443
444    sub array {
445        my ( $self, $name ) = @_;
446        my $wfid   = $self->get_wfid;
447        my $client = $self->get_client;
448        my $msg    = $self->get_msg;
449
450        if ( not $msg ) {
451            $msg = $client->send_receive_command_msg( 'get_workflow_info',
452                { ID => $wfid } );
453        }
454
455        $self->set_msg($msg);
456        if ( $self->error ) {
457            $@ = 'Error getting workflow info: ' . Dumper($msg);
458            return;
459        }
460
461        my $val = OpenXPKI::Server::Workflow::WFObject::WFArray->new(
462            {
463                workflow => $msg->{PARAMS}->{WORKFLOW},
464                context_key => $name,
465            }
466        );
467        if ( not $val ) {
468            $self->diag("WFArray->new($name) failed: $@");
469        }
470        return $val;
471    }
472
473    sub state {
474        my ($self) = @_;
475        my $wfid   = $self->get_wfid;
476        my $client = $self->get_client;
477        my $msg    = $self->get_msg;
478
479        if ( defined $msg and defined $msg->{PARAMS}->{WORKFLOW}->{STATE} ) {
480            return $msg->{PARAMS}->{WORKFLOW}->{STATE};
481        }
482
483        $msg = $client->send_receive_command_msg( 'get_workflow_info',
484            { ID => $wfid } );
485
486        $self->set_msg($msg);
487        if ( $self->error ) {
488            $@ = 'Error getting workflow info: ' . Dumper($msg);
489            return;
490        }
491
492   #        $self->diag(
493   #            "WF: " . join( ', ', keys %{ $msg->{PARAMS}->{WORKFLOW} } ) );
494        return $msg->{PARAMS}->{WORKFLOW}->{STATE};
495    }
496
497    sub search {
498        my ( $self, $key, $value ) = @_;
499        my $client = $self->get_client;
500
501        my $msg = $client->send_receive_command_msg(
502            'search_workflow_instances',
503            {   CONTEXT => [
504                    {   KEY   => $key,
505                        VALUE => $value,
506                    },
507                ],
508                TYPE => $self->get_wftype(),
509            },
510            )
511            or die "Error running search_workflow_instances: " . $self->dump;
512
513        return @{ $msg->{PARAMS} };
514    }
515
516    sub reset{
517        my $self = shift;
518        $self->set_msg(undef);
519    }
520
521    sub error {
522        my $self = shift;
523        my $msg  = $self->get_msg;
524
525        if (   $msg
526            && exists $msg->{'SERVICE_MSG'}
527            && $msg->{'SERVICE_MSG'} eq 'ERROR' )
528        {
529            return $msg->{'LIST'}->[0]->{'LABEL'} || 'Unknown error';
530        }
531        else {
532            return;
533        }
534    }
535
536    sub dump {
537        my $self = shift;
538        foreach (@_) {
539            Test::More::diag($_);
540        }
541        Test::More::diag("Current Test Instance:");
542        foreach my $k (qw( user wfid )) {
543            my $acc = 'get_' . $k;
544            my $v   = $self->$acc();
545            if ( not defined $v ) {
546                $v = '<undef>';
547            }
548            Test::More::diag("\t$k: $v");
549        }
550        my $msg = $self->get_msg;
551        if ($msg) {
552            Test::More::diag('Contents of $msg:');
553            Test::More::diag( Dumper($msg) );
554        }
555    }
556
557    sub disconnect {
558        my $self   = shift;
559        my $client = $self->get_client;
560        eval { $client && $client->send_receive_service_msg('LOGOUT'); };
561        $self->set_client(undef);
562        $self->set_msg(undef);
563    }
564
565    # Handle cleanup
566    sub DEMOLISH {
567        my ( $self, $id ) = @_;
568    }
569
570    ############################################################
571    # Map Test::More subroutines
572    ############################################################
573    no warnings 'redefine';
574
575    sub diag {
576        my $self = shift;
577        Test::More::diag(@_);
578    }
579
580    sub plan {
581        my $self = shift;
582        Test::More::plan(@_);
583    }
584
585    sub skip {
586        my $self = shift;
587        Test::More::skip(@_);
588    }
589
590    sub is ($$;$) {
591        my ( $self, $got, $expected, $testname ) = @_;
592        return Test::More::is( $got, $expected, $testname );
593    }
594
595    sub isnt ($$;$) {
596        my ( $self, $got, $expected, $testname ) = @_;
597        return Test::More::isnt( $got, $expected, $testname );
598    }
599
600    sub ok ($;$) {
601        my ( $self, $test, $name ) = @_;
602        return Test::More::ok( $test, $name );
603    }
604
605    sub nok ($;$) {
606        my ( $self, $test, $name ) = @_;
607        return Test::More::ok( !$test, $name );
608    }
609
610    sub like ($$;$) {
611        my ( $self, $test, $regexp, $name ) = @_;
612        return Test::More::like( $test, $regexp, $name );
613    }
614}
615
6161;
617
618__END__
619
620=head1 NAME
621
622OpenXPKI::Test::QA::More
623
624=head1 DESCRIPTION
625
626This is a helper module for the OpenXPKI test suites. In contrast to
627OpenXPKI::Test, this uses an OOP interface that, hopefully, will
628simplify handling the connection to the OpenXPKI daemon.
629
630Subclassing is supported, so a test script can have an in-line package
631definition to extend this class.
632
633=head1 SYNOPSIS
634
635  #!/usr/bin/perl
636
637  use strict;
638  use warnings;
639
640  package MyWFModuleTest;
641  use base qw( OpenXPKI::Test::QA::More );
642
643  # object attributes
644  my %myattrs : ATTR;
645
646  sub myproc {
647    my $self = shift;
648    ...
649  }
650
651  package main;
652
653  ...
654
655  my $test = MyWFModuleTest->new();
656  $test->plan( tests => 3);
657
658  $test->connect_ok(user => 'USER', password => 'PASS',
659        socketfile => 'SOCKFILE', realm => 'REALM');
660  $test->create_ok($wftype, {});
661  $test->state_eq('EXPECTED_STATE');
662  $test->disconnect();
663
664
665=head1 TEST METHODS
666
667These test subroutines act as test methods similar to those found in
668Test::More. They will result in an output line that can be parsed
669by Test::Harness.
670
671=head2 $test->connect_ok PARAMS
672
673Creates a connection to the OpenXPKI daemon. The arguments, a named-parameter
674list, contain the key 'testname', which describes the test for Test::Harness.
675If not set, the default test name is printed.
676In addition, the arguments for connect() are used.
677
678=head2 $test->create_ok WFTYPE, PARAMSREF, [ TESTNAME ]
679
680Creates a new workflow instance of the given WFTYPE, passing the
681reference to the parameter hash PARAMSREF. The TESTNAME is optional.
682
683=head2 $test->create_nok WFTYPE, PARAMSREF, [ TESTNAME ]
684
685Attempts to create a new workflow instance of the given WFTYPE, passing the
686reference to the parameter hash PARAMSREF. It is expected that the create()
687will fail (i.e.: if the create is successful, this test fails). The
688TESTNAME is optional.
689
690=head2 $test->execute_ok ACTION, PARAMSREF, [ TESTNAME ]
691
692Executes the given ACTION on the current workflow, passing the PARAMSREF.
693TESTNAME is optional.
694
695=head2 $test->execute_nok ACTION, PARAMSREF, [ TESTNAME ]
696
697Executes the given ACTION on the current workflow, passing the PARAMSREF.
698An execution error is expected (i.e.: if the execution is successful, this test fails)
699TESTNAME is optional.
700
701=head2 $test->param_is NAME, EXPECTED, [ TESTNAME ]
702
703Fetches the value of the given workflow context parameter NAME and compares
704it with the expected value EXPECTED.
705
706Optionally, the test name TESTNAME may be specified.
707
708=head2 $test->state_is EXPECTED, [ TESTNAME ]
709
710Fetches the state of the workflow and compares
711it with the expected value EXPECTED.
712
713Optionally, the test name TESTNAME may be specified.
714
715=head1 HELPER METHODS
716
717The helper subroutines provide functionality that doesn't result in
718a test (e.g.: "1... ok") entry for harness.
719
720=head2 $test->connect
721
722Creates a connection to the OpenXPKI daemon. The arguments, a named-parameter
723list, contain the following keys:
724
725=over 8
726
727=item user
728
729The name of the user to log in as. [optional]
730
731=item pass
732
733The password to use. [optional]
734
735=item socketfile
736
737The socket file to use for the connection.
738
739=item realm
740
741The PKI Realm to use for the connection. [optional]
742
743=back
744
745On success, a reference to SELF is returned.
746
747=head2 $test->create WFTYPE, [ PARAMSREF ]
748
749Create a workflow of the given workflow type WFTYPE. Optionally, a reference
750to a named-parameter list PARAMSREF may be passed.
751
752On error, C<undef> is returned and the reason is in C<$@>.
753
754=head2 $test->execute ACTION, [ PARAMSREF ]
755
756Executes the ACTION for the current workflow. Optionally, a reference to
757a named-parameter list PARAMSREF may be passed.
758
759=head2 $test->state
760
761Returns the state of the current workflow
762
763=head2 $test->wfid
764
765Returns the workflow ID of the current workflow
766
767=head2 $test->param NAME
768
769Returns the value of the given context parameter for the current workflow.
770
771=head2 $test->reset
772
773resets the internal cached workflow info. can be used to force  "fresh" workflow data from server.
774usefull if execution results in an (expected) error and you want to check some workflow property (e.g. context param)
775
776=head2 $test->array NAME
777
778Returns a WFArray object instance that is currently stored in the NAME
779workflow context parameter.
780
781=head2 $test->search KEY, VALUE
782
783Searches the workflow records using the given KEY and VALUE. Optionally,
784a FILTER may be specified as a grep block and SORTREF may be specified
785as a sort block.
786
787  my @results = $test->search( 'token_id', $token);
788
789=head2 $test->error
790
791Returns the error string if the most recent server call failed. Otherwise,
792C<undef> is returned.
793
794=head2 $test->set_verbose( 0 | 1 )
795
796Sets the verbosity off or on.
797
798=head2 $test->disconnect
799
800Close the current connection to the OpenXPKI daemon
801
802=head1 Test::More SUBROUTINES
803
804The following subroutines are wrapped in instance methods of this class:
805
806diag, plan, ok, is, like
807
808
809