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