App-Dochazka-CLI
view release on metacpan or search on metacpan
- Parser.pm: add 'GET CURRENT PRIV' command
- bin/dochazka-cli: fix privilege brokenness; add status text to command output
0.021 2014-10-21 10:44 CEST
- Parser.pm: add 'GET EMPLOYEE COUNT' and get rid of conflicting 'GET
EMPLOYEE [STRING]'
0.022 2014-10-21 16:26 CEST
- bin/dochazka-cli: show response body on NOTICE status as well as OK
- HTTP.pm: explicitly import GET PUT POST DELETE from HTTP::Request::Common
- Parser.pm: properly implement 'metaparam/:param' and 'not_implemented'
resources
0.023 2014-10-21 22:24 CEST
- Parser.pm: fix $anything regex variable; support 'forbidden' resource; add
other missing top-level resources so now all are supported
0.024 2014-10-22 16:42 CEST
- Parser.pm: add POST EMPLOYEE EID command
0.025 2014-10-23 10:55 CEST
bin/dochazka-cli view on Meta::CPAN
my $interactive = -t STDIN ? 1 : 0;
my $pipe = -p STDIN ? 1 : 0;
# initialize CLI client
my $status = init_cli_client(
distro => 'App-Dochazka-CLI',
sitedir => [ @sitedirs ],
early_debug => $early_debug,
);
if ( $status->not_ok ) {
print $status->code . ' (' . $status->level . ') ' . $status->text . "\n";
print "Response: " . Dumper( $status->payload ) . "\n";
exit;
}
init_logger();
init_prompt();
# determine server
if ( ! ( $server = $ARGV[0] ) ) {
if ( $server = $meta->MREST_CLI_URI_BASE ) {
bin/dochazka-cli view on Meta::CPAN
}
print "Authenticating to server at $server as user $user\n";
if ( ! $password ) {
ReadMode ('noecho');
print "Password: ";
chomp( $password = <STDIN> );
ReadMode ('restore');
print "\n";
}
my $status = authenticate_to_server( user => $user, password => $password );
if ( $status->not_ok ) {
# Handle two classic scenarios:
# 1. server not running
if ( $status->payload =~ m/Connection refused/ ) {
print "Server refused connection - is it running?\n";
exit;
}
# 2. authentication failed
if ( $status->text =~ m/Authentication failed/ ) {
print "Authentication failed.\n";
lib/App/Dochazka/CLI/Commands/Employee.pm view on Meta::CPAN
=cut
sub determine_priv {
my ( $emp ) = @_;
return undef unless ref( $emp ) eq 'App::Dochazka::REST::Model::Employee';
return undef unless $emp->eid and $emp->nick;
# GET priv/eid/:eid
my $status = send_req( 'GET', 'priv/eid/' . $emp->eid );
if ( $status->not_ok ) {
$log->error( "Could not determine priv level of employee -> " . $emp->nick .
"<- because: " . $status->text );
return undef;
}
return $status->payload->{'priv'};
}
=head3 determine_supervisor
lib/App/Dochazka/CLI/Commands/Interval.pm view on Meta::CPAN
sub _interval_new {
my ( $code, $tsrange, $long_desc ) = validate_pos( @_,
{ type => SCALAR },
{ type => SCALAR },
{ type => SCALAR|UNDEF, optional => 1 },
);
# get aid from code
my $status = send_req( 'GET', "activity/code/$code" );
if ( $status->not_ok ) {
if ( $status->code eq "DISPATCH_SEARCH_EMPTY" and
$status->text =~ m/Search over activity with key -\>code equals .+\<- returned nothing/
) {
return $CELL->status_err( 'DOCHAZKA_CLI_WRONG_ACTIVITY', args => [ $code ] );
}
return rest_error( $status, "Determine AID from code" ) unless $status->ok;
}
my $aid = $status->payload->{'aid'};
# assemble entity
my $entity_perl = {
'aid' => $aid,
'intvl' => $tsrange,
};
$entity_perl->{'long_desc'} = $long_desc if $long_desc;
my $entity = encode_json $entity_perl;
# send the request
$status = send_req( 'POST', "interval/new", $entity );
if ( $status->not_ok ) {
# if ... possible future checks for common errors
# elsif ... other common errors
return rest_error( $status, "Insert new attendance interval" ) unless $status->ok;
}
return $CELL->status_ok( 'DOCHAZKA_CLI_NORMAL_COMPLETION',
payload => _print_interval( $status->payload ) );
}
lib/App/Dochazka/CLI/Commands/Interval.pm view on Meta::CPAN
Given an employee object and a tsrange, print all matching intervals
=cut
sub _print_intervals_tsrange {
my ( $emp, $tsr ) = @_;
my $eid = $emp->eid;
my $nick = $emp->nick;
my $status = send_req( 'GET', "interval/eid/$eid/$tsr" );
if ( $status->not_ok and $status->code eq 'DISPATCH_NOTHING_IN_TSRANGE' ) {
return $CELL->status_ok( 'DOCHAZKA_CLI_NORMAL_COMPLETION', payload => $status->text );
}
return rest_error( $status, "Get intervals for employee $nick (EID $eid) in range $tsr" )
unless $status->ok;
my $pl = '';
$pl .= "Attendance intervals of $nick (EID $eid)\n";
$pl .= "in the range $tsr\n\n";
my $t = Text::Table->new( 'IID', 'Begin', 'End', 'Code', 'Description' );
lib/App/Dochazka/CLI/Util.pm view on Meta::CPAN
die( "AH! Not an EMPLOYEE_SPEC" ) unless $ARGS{key} =~ m/=/;
my ( $key_spec, $key ) = $ARGS{key} =~ m/^(.*)\=(.*)$/;
my $minimal = $ARGS{minimal} ? '/minimal' : '';
my $status;
if ( $key_spec =~ m/^emp/i ) {
$status = send_req( 'GET', "employee/nick/$key$minimal" );
BREAK_OUT: {
last BREAK_OUT if $status->not_ok and $status->payload and $status->payload->{'http_code'} == 403;
if ( $status->not_ok and $status->payload and $status->payload->{'http_code'} == 404 ) {
$status = send_req( 'GET', "employee/sec_id/$key$minimal" );
if ( $status->not_ok and $status->payload and $status->payload->{'http_code'} != 500 and looks_like_number( $key ) ) {
$status = send_req( 'GET', "employee/eid/$key$minimal" );
}
}
}
} elsif ( $key_spec =~ m/^nic/i ) {
$status = send_req( 'GET', "employee/nick/$key$minimal" );
} elsif ( $key_spec =~ m/^sec/i ) {
$status = send_req( 'GET', "employee/sec_id/$key$minimal" );
} elsif ( $key_spec =~ m/^eid/i ) {
$status = send_req( 'GET', "employee/eid/$key$minimal" );
lib/App/Dochazka/CLI/Util.pm view on Meta::CPAN
=cut
sub parse_test {
#print ( 'parse_test arg list: ' . join( ' ', @_ ) . "\n" );
my ( %PARAMHASH ) = @_;
if ( $PARAMHASH{'PARSE_TEST'} ) {
return $CELL->status_ok( 'DOCHAZKA_CLI_PARSE_TEST',
payload => (caller(1))[3] );
}
return $CELL->status_not_ok( 'DOCHAZKA_CLI_PARSE_TEST' );
}
=head2 refresh_current_emp
REST calls are cheap, so look up C<< $current_emp >> again just to make sure.
=cut
sub refresh_current_emp {
my $status = send_req( 'GET', 'employee/eid/' . $current_emp->eid );
if ( $status->not_ok ) {
$log->crit( "Problem with data integrity (current employee)" );
return $status;
}
$current_emp = App::Dochazka::Common::Model::Employee->spawn( %{ $status->payload } );
return $status;
}
=head2 rest_error
t/001-init.t view on Meta::CPAN
is( $rv->level, 'OK', "process_command( $cmd ) returned OK status" );
is( $rv->{'http_status'}, '200 OK' );
}
my ( $cmd, $rv, $rv_type, $status );
$rv = init_unit();
$rv_type = ref( $rv );
if ( $rv_type ne 'App::CELL::Status' or $rv->not_ok ) {
diag "init_unit returned unexpected status:";
diag( Dumper $rv );
BAIL_OUT(0);
}
$rv = authenticate_to_server( user => 'root', password => 'immutable', quiet => 1 );
$rv_type = ref( $rv );
if ( $rv_type ne 'App::CELL::Status' or $rv->not_ok ) {
if ( $rv->{'http_status'} =~ m/500 Can\'t connect/ ) {
plan skip_all => "Can't connect to server";
} else {
diag "authenticate_to_server returned unexpected status:";
diag( Dumper $rv );
BAIL_OUT(0);
}
}
create_employees_carefully( 'worker', 'active', 'Joe Working Stiff' );
t/cmd_active/activity.t view on Meta::CPAN
use Test::Warnings;
my ( $cmd, $rv );
note( 'initialize unit' );
$rv = init_unit();
plan skip_all => "init_unit failed with status " . $rv->text unless $rv->ok;
note( 'authenticate to server' );
$rv = authenticate_to_server( user => 'worker', password => 'worker', quiet => 1 );
if ( $rv->not_ok and $rv->{'http_status'} =~ m/500 Can\'t connect/ ) {
plan skip_all => "Can't connect to server";
}
isnt( $meta->MREST_CLI_URI_BASE, undef, 'MREST_CLI_URI_BASE is defined after initialization' );
$cmd = "ACTIVITY";
$rv = process_command( $cmd );
is( ref( $rv ), 'App::CELL::Status' );
is( $rv->level, 'OK' );
is( $rv->code, 'DOCHAZKA_CLI_NORMAL_COMPLETION' );
t/cmd_active/employee.t view on Meta::CPAN
use Data::Dumper;
use Test::More;
use Test::Warnings;
my ( $cmd, $rv );
$rv = init_unit();
plan skip_all => "init_unit failed with status " . $rv->text unless $rv->ok;
$rv = authenticate_to_server( user => 'worker', password => 'worker', quiet => 1 );
if ( $rv->not_ok and $rv->{'http_status'} =~ m/500 Can\'t connect/ ) {
plan skip_all => "Can't connect to server";
}
isnt( $meta->MREST_CLI_URI_BASE, undef, 'MREST_CLI_URI_BASE is defined after initialization' );
$cmd = "EMPLOYEE";
$rv = process_command( $cmd );
ok( ref( $rv ) eq 'App::CELL::Status' );
is( $rv->level, 'OK' );
like( $rv->payload, qr/Nick:\s+worker/ );
t/cmd_active/interval.t view on Meta::CPAN
use Data::Dumper;
use Test::More;
use Test::Warnings;
my ( $cmd, $rv );
$rv = init_unit();
plan skip_all => "init_unit failed with status " . $rv->text unless $rv->ok;
$rv = authenticate_to_server( user => 'worker', password => 'worker', quiet => 1 );
if ( $rv->not_ok and $rv->{'http_status'} =~ m/500 Can\'t connect/ ) {
plan skip_all => "Can't connect to server";
}
isnt( $meta->MREST_CLI_URI_BASE, undef, 'MREST_CLI_URI_BASE is defined after initialization' );
note( 'INTERVAL displays today\'s intervals (but there are none)' );
$cmd = "INTERVAL";
$rv = process_command( $cmd );
is( ref( $rv ), 'App::CELL::Status' );
is( $rv->level, 'OK' );
t/cmd_admin/activity.t view on Meta::CPAN
use Data::Dumper;
use Test::More;
use Test::Warnings;
my ( $cmd, $rv );
$rv = init_unit();
plan skip_all => "init_unit failed with status " . $rv->text unless $rv->ok;
$rv = authenticate_to_server( user => 'root', password => 'immutable', quiet => 1 );
if ( $rv->not_ok and $rv->{'http_status'} =~ m/500 Can\'t connect/ ) {
plan skip_all => "Can't connect to server";
}
isnt( $meta->MREST_CLI_URI_BASE, undef, 'MREST_CLI_URI_BASE is defined after initialization' );
$cmd = "ACTIVITY ALL";
$rv = process_command( $cmd );
is( ref( $rv ), 'App::CELL::Status' );
is( $rv->level, 'OK' );
is( $rv->code, 'DOCHAZKA_CLI_NORMAL_COMPLETION' );
t/cmd_admin/employee-utf8.t view on Meta::CPAN
use Test::Warnings;
$debug_mode = 1;
my ( $cmd, $rv );
$rv = init_unit();
plan skip_all => "init_unit failed with status " . $rv->text unless $rv->ok;
$rv = authenticate_to_server( user => 'root', password => 'immutable', quiet => 1 );
if ( $rv->not_ok and $rv->{'http_status'} =~ m/500 Can\'t connect/ ) {
plan skip_all => "Can't connect to server";
}
isnt( $meta->MREST_CLI_URI_BASE, undef, 'MREST_CLI_URI_BASE is defined after initialization' );
note( 'Create testing employee with UTF-8 characters' );
$cmd = "PUT employee nick george { \"fullname\" : \"Karel OmáÄka\" }";
$rv = process_command( $cmd );
ok( ref( $rv ) eq 'App::CELL::Status' );
ok( $rv->ok );
t/cmd_admin/employee.t view on Meta::CPAN
use Test::Warnings;
$debug_mode = 1;
my ( $cmd, $rv );
$rv = init_unit();
plan skip_all => "init_unit failed with status " . $rv->text unless $rv->ok;
$rv = authenticate_to_server( user => 'root', password => 'immutable', quiet => 1 );
if ( $rv->not_ok and $rv->{'http_status'} =~ m/500 Can\'t connect/ ) {
plan skip_all => "Can't connect to server";
}
isnt( $meta->MREST_CLI_URI_BASE, undef, 'MREST_CLI_URI_BASE is defined after initialization' );
#=====================================
# EMPLOYEE
# EMPLOYEE SHOW
# EMPLOYEE PROFILE
# EMPLOYEE_SPEC
t/cmd_admin/employee.t view on Meta::CPAN
ok( ref( $rv ) eq 'App::CELL::Status' );
is( $rv->level, 'OK' );
is( $rv->code, 'DISPATCH_EMPLOYEE_FOUND' );
is( $rv->payload->{'sec_id'}, 'test123' );
is( $rv->payload->{'nick'}, 'root' );
note( 'Set someone else\'s Workforce ID to the same thing' );
$cmd = "EMPLOYEE=worker SET SEC_ID test123";
$rv = process_command( $cmd );
ok( ref( $rv ) eq 'App::CELL::Status' );
ok( $rv->not_ok );
like( $rv->payload, qr/duplicate key value violates unique constraint/ );
note( 'Set someone else\'s Workforce ID to HAMBURG_SUBST' );
$cmd = "EMPLOYEE=worker SET SEC_ID HAMBURG_SUBST";
$rv = process_command( $cmd );
ok( ref( $rv ) eq 'App::CELL::Status' );
ok( $rv->ok );
like( $rv->payload, qr/HAMBURG_SUBST/ );
note( 'Check that it really got set to HAMBURG_SUBST' );
t/cmd_admin/history.t view on Meta::CPAN
use Test::Warnings;
my ( $cmd, $rv );
note( 'initialize unit' );
$rv = init_unit();
plan skip_all => "init_unit failed with status " . $rv->text unless $rv->ok;
note( 'authenticate to server' );
$rv = authenticate_to_server( user => 'root', password => 'immutable', quiet => 1 );
if ( $rv->not_ok and $rv->{'http_status'} =~ m/500 Can\'t connect/ ) {
plan skip_all => "Can't connect to server";
}
isnt( $meta->MREST_CLI_URI_BASE, undef, 'MREST_CLI_URI_BASE is defined after initialization' );
note( '****************************************************************************' );
note( 'In t/001-init.t we created an employee "worker" with privlevel "active"' );
note( 'This privlevel was achieved by inserting a record in the privhistory table' );
note( 'Since t/001-init.t always runs first, we can assume that "worker" will have' );
note( 'one and only one privhistory record at this point.' );
t/cmd_inactive/activity.t view on Meta::CPAN
use Test::More;
use Test::Warnings;
my ( $cmd, $rv );
note( 'initialize unit' );
$rv = init_unit();
plan skip_all => "init_unit failed with status " . $rv->text unless $rv->ok;
$rv = authenticate_to_server( user => 'absent', password => 'absent', quiet => 1 );
if ( $rv->not_ok and $rv->{'http_status'} =~ m/500 Can\'t connect/ ) {
plan skip_all => "Can't connect to server";
}
isnt( $meta->MREST_CLI_URI_BASE, undef, 'MREST_CLI_URI_BASE is defined after initialization' );
$cmd = "ACTIVITY ALL";
$rv = process_command( $cmd );
is( ref( $rv ), 'App::CELL::Status' );
is( $rv->{'http_status'}, '403 Forbidden' );
t/cmd_inactive/employee.t view on Meta::CPAN
use Test::More;
use Test::Warnings;
my ( $cmd, $rv );
note( 'initialize unit' );
$rv = init_unit();
plan skip_all => "init_unit failed with status " . $rv->text unless $rv->ok;
$rv = authenticate_to_server( user => 'absent', password => 'absent', quiet => 1 );
if ( $rv->not_ok and $rv->{'http_status'} =~ m/500 Can\'t connect/ ) {
plan skip_all => "Can't connect to server";
}
isnt( $meta->MREST_CLI_URI_BASE, undef, 'MREST_CLI_URI_BASE is defined after initialization' );
$cmd = "EMPLOYEE";
$rv = process_command( $cmd );
ok( ref( $rv ) eq 'App::CELL::Status' );
is( $rv->level, 'OK' );
like( $rv->payload, qr/Nick:\s+absent/ );
t/cmd_passerby/activity.t view on Meta::CPAN
use Test::More;
use Test::Warnings;
my ( $cmd, $rv );
note( 'initialize unit' );
$rv = init_unit();
plan skip_all => "init_unit failed with status " . $rv->text unless $rv->ok;
$rv = authenticate_to_server( user => 'demo', password => 'demo', quiet => 1 );
if ( $rv->not_ok and $rv->{'http_status'} =~ m/500 Can\'t connect/ ) {
plan skip_all => "Can't connect to server";
}
isnt( $meta->MREST_CLI_URI_BASE, undef, 'MREST_CLI_URI_BASE is defined after initialization' );
$cmd = "ACTIVITY ALL";
$rv = process_command( $cmd );
is( ref( $rv ), 'App::CELL::Status' );
is( $rv->{'http_status'}, '403 Forbidden' );
t/cmd_passerby/employee.t view on Meta::CPAN
use Test::Warnings;
my ( $cmd, $rv );
note( 'initialize unit' );
$rv = init_unit();
plan skip_all => "init_unit failed with status " . $rv->text unless $rv->ok;
note( 'authenticate to server' );
$rv = authenticate_to_server( user => 'demo', password => 'demo', quiet => 1 );
if ( $rv->not_ok and $rv->{'http_status'} =~ m/500 Can\'t connect/ ) {
plan skip_all => "Can't connect to server";
}
note( 'sanity check' );
isnt( $meta->MREST_CLI_URI_BASE, undef, 'MREST_CLI_URI_BASE is defined after initialization' );
note( 'EMPLOYEE command' );
$cmd = "EMPLOYEE";
$rv = process_command( $cmd );
ok( ref( $rv ) eq 'App::CELL::Status' );
t/cmd_passerby/schedule.t view on Meta::CPAN
use Test::Warnings;
my ( $cmd, $rv );
note( 'initialize unit' );
$rv = init_unit();
plan skip_all => "init_unit failed with status " . $rv->text unless $rv->ok;
note( 'authenticate to server' );
$rv = authenticate_to_server( user => 'demo', password => 'demo', quiet => 1 );
if ( $rv->not_ok and $rv->{'http_status'} =~ m/500 Can\'t connect/ ) {
plan skip_all => "Can't connect to server";
}
isnt( $meta->MREST_CLI_URI_BASE, undef, 'MREST_CLI_URI_BASE is defined after initialization' );
$cmd = "SCHEDULE DUMP";
$rv = process_command( $cmd );
is( ref( $rv ), 'App::CELL::Status' );
is( $rv->level, 'OK' );
is( $rv->code, 'DOCHAZKA_CLI_MEMSCHED_EMPTY' );
t/util/auth.t view on Meta::CPAN
use Test::Warnings;
my ( $status, $rv, $rv_type );
note( 'init_cli_client' );
$rv = init_unit();
diag( Dumper $rv ) unless $rv->ok;
note( 'authenticate_to_server as root' );
$rv = authenticate_to_server( user => 'root', password => 'immutable', quiet => 1 );
if ( $rv->not_ok and $rv->{'http_status'} =~ m/500 Can\'t connect/ ) {
plan skip_all => "Can't connect to server";
}
isnt( $meta->MREST_CLI_URI_BASE, undef, 'MREST_CLI_URI_BASE is defined after initialization' );
#note( "authenticate to server with no arguments" );
#is( $current_emp, undef, '$current_emp is undefined before authentication' );
#is( $current_priv, undef, '$current_priv is undefined before authentication' );
#$rv = authenticate_to_server();
#is( $rv->level, 'OK' );
t/util/determine_employee.t view on Meta::CPAN
my ( $status, $rv, $rv_type );
note( 'init_unit' );
$rv = init_unit();
diag( Dumper $rv ) unless $rv->ok;
note( 'authenticate to server' );
$rv = authenticate_to_server( user => 'root', password => 'immutable', quiet => 1 );
$rv_type = ref( $rv );
if ( $rv_type ne 'App::CELL::Status' or $rv->not_ok ) {
if ( $rv->{'http_status'} =~ m/500 Can\'t connect/ ) {
plan skip_all => "Can't connect to server";
} else {
diag "authenticate_to_server returned unexpected status:";
diag( Dumper $rv );
BAIL_OUT(0);
}
}
is( $rv->code, 'DOCHAZKA_CLI_AUTHENTICATION_OK' );
( run in 1.929 second using v1.01-cache-2.11-cpan-0a987023a57 )