App-Dochazka-REST
view release on metacpan or search on metacpan
- work on development-checklist
- t/: standardize method order (GET, PUT, POST, DELETE); adapt units
0.198 2014-10-21 12:10 CEST
- Dispatch.pm: document all target subroutines; put into alphabetical order
by resource name/path
0.199 2014-10-21 16:31 CEST
- Hackweek Day 2
- dispatch_Message_en.conf: add DISPATCH_RESOURCE_NOT_IMPLEMENTED
- dispatch_Top_Config.pm: implement 'not_implemented' resource
- Dispatch.pm: implement 'not_implemented' resource, alphabetical order
tweak
- t/: add missing top-level dispatch tests
- new ../development-checklist chart to clarify and streamline
resource-implementation workflow
0.200 2014-10-21 22:29 CEST
- ../development-checklist: finish implementing top-level resources
- Dispatch.pm: when getting site and meta params, show file and line
number along with other metadata; tweak resource documentation
- t/: some tests failing due to bug in App::CELL::Config->get_param_meta
- Dispatch/Privhistory.pm: repurpose _current_priv so it works for the new
resources added in this commit; rename _eid and _nick to _history_eid and
_history_nick, respectively
0.214 2014-10-27 13:12 CET
- config/dispatch/top_Config.pm: add 'cli' property to all top-level
resource definitions; put into alphabetical order; rename 'privhistory'
to 'priv'
- Dispatch.pm: make 'docu' resource return "resource => ''" when called
without an argument, instead of "resource => undef"; make
"not_implemented" resource include HTTP method in payload
0.215 2014-10-27 13:39 CET
- config/dispatch/employee_Config.pm, config/dispatch/priv_Config.pm: add
'cli' properties to all resource definitions
- ../development-checklist: complete manual CLI testing of all top-level
and employee resources
0.216 2014-10-27 14:29 CET
- config/dispatch/priv_Config.pm: fix 'priv/eid/:eid/?:ts' and
'priv/nick/:nick/?:ts' resource definitions
- config/dispatch/priv_Config.pm: alphabetical order tweak
- Test.pm: export all the test functions (EXPORT instead of EXPORT_OK); bring
in create_testing_employee and delete_testing_employee
- STATUS: all top-level, employee, and priv resources implemented and tested,
ready to start work on activity, interval, etc. resources
0.220 2014-10-28 09:35 CET
- MANIFEST: add Dispatch/Activity.pm
- config/dispatch/activity_Config.pm: add 'activity/all' resource definition
- config/dispatch/top_Config.pm: add 'activity' resource definition; rename
'_not_implemented' target to 'not_implemented' because we are now exporting
it from Dispatch/Shared.pm
- config/dispatch_Config.pm: uncomment DISPATCH_RESOURCES_ACTIVITY
- Dispatch.pm: import not_implemented target from Dispatch/Shared.pm
- Dispatch/Employee.pm: fix debug messages
- Dispatch/Privhistory.pm: import priv_by_eid from the right module
- Dispatch/Shared.pm: export 'not_implemented' routine
- Resource.pm: add 'use App::Dochazka::REST::Dispatch::Activity' so activity
targets will work
0.221 2014-10-28 12:08 CET
- MANIFEST: add t/dispatch/activity.t
- config/sql/: add 'SQL_ACTIVITY_SELECT_ALL'; add 'disabled'
field to 'activities' table; adapt SQL statements where appropriate
- t/dispatch/activity.t: new unit for activity dispatch tests
0.222 2014-10-28 21:51 CET
- Model/Shared.pm: return decoded schedule (hashref) from schedule_by_eid
- t/dispatch/schedule.t: uncomment/adapt some tests
- t/: get model units to run cleanly again
0.242 2014-11-04 08:30 CET
- config/dispatch/schedule_Config.pm: put resource definitions in alphabetical order;
add missing POD; add missing 'schedule/intervals' resource definition
0.243 2014-11-04 09:56 CET
- schedule_Config.pm, Dispatch/Schedule.pm: make 'schedule/history/...'
resources use "not_implemented" dispatch target so they don't vomit 500
0.244 2014-11-04 11:32 CET
- schedule_Config.pm: split 'schedule/intervals/?:shid' into two separate
resources for parsing clarity
0.245 2014-11-04 17:50 CET
- Build.PL: require App::Dochazka 0.175 for 'ssid' (instead of 'scratch_sid')
- schedule_Config.pm: 'schedule/intervals' is POST and DELETE only; activate
DELETE on 'schedule/intervals/:sid'; rename ':shid' parameter to ':sid'
- rename 'scratch_sid' field/property of intervals to 'ssid'
0.288 2014-11-19 10:05 CET
- Dispatch/Lock.pm: lay groundwork for locks
- t/dispatch/interval.t: new tests
- interval_Config.pm, dispatch_Message_en.conf: minor fixes
- Dispatch/Interval.pm: add special ACL handling
- Model/Interval.pm: fix bug (wrong order of properties in call to 'cud')
- Test.pm: let 'req' handle any user as long as "passhash" property is
set the same as "nick"
0.289 2014-11-19 11:08 CET
- interval_Config.pm: make not-implemented resources use 'not_implemented'
dispatch target
- t/dispatch/interval.pm: add some missing boilerplate tests
0.290 2014-11-19 11:23 CET
- interval_Config.pm: 'interval/nick/:nick/:tsrange' resource was broken due to
missing EOH - fixed
- t/dispatch/interval.t: $base for 'interval/nick/:nick/:tsrange' resource was
set to wrong value - fixed
0.291 2014-11-19 15:19 CET
- t/model/: add '+01' to some timestamp literals because they are now timestamptz
0.305 2014-11-24 18:11 CET
- dbinit_Config.pm: notice that we already have a 'valid_intvl' trigger; revamp
'intervals' and 'locks' triggers to use it
- t/dispatch/interval_lock.t: add a group of tests to keep track of which
pathological tsranges ('intervals' in Dochazka terms) we are successfully
checking for
0.306 2014-11-26 09:31 CET
- dbinit_Config.pm: add 'intvl_not_locked' trigger before update or insert on
'intervals' table - checks to make sure the interval would not overlap with
any existing lock
- Model/Shared.pm: fix bug where 'load' routine was needlessly adding
'count => 1' to the payload, which is supposed to be just an object
- t/: some tests started to fail because we were creating intervals and locks
with the same intervals - fixed by changing the lock interval
- t/dispatch/interval_lock.t: now that we have a functioning trigger, add tests
that attempt to insert intervals that conflict with a lock
- t/model/triggers: add new subdirectory for trigger tests
- t/model/triggers/immutable_id.t: new unit to test triggers that make ID
insert and update; confidently add 'NOT NULL' constraint to 'disabled' fields
- t/sql/disabled_to_zero.t: adapt to current state
- t/model/schedule.t: add notes the way it should have been from the beginning
0.419 2015-04-03 18:06 CEST
- ResourceDefs.pm: change ACL of 'GET schedule/all' so inactives and actives
can do it, too
- t/dispatch/schedule.t: add appropriate test cases
0.420 2015-04-04 21:18 CEST
- SQL: implement 'not_before_1892' function to enforce sane timestamp policy
(no dates before 1892 in the database)
- t/: adapt tests; add test cases
0.421 2015-04-05 13:34 CEST
- REST/Shared.pm: in 'shared_get_privsched', return 404 if no priv/schedule
assigned (instead of returning 200 OK with a null priv/schedule)
- t/dispatch/schedule.t: adapt tests
0.422 2015-04-05 20:45 CEST
- dbinit_Config.pm: make schedule_at_timestamp return SID instead of the
- Dispatch.pm: add handler_get_employee_ldap() for GET employee/nick/:nick/ldap
- Auth.pm: populate certain employee attributes from LDAP upon successful LDAP autocreate
- REST_Config.pm: default value for DOCHAZKA_LDAP_POPULATE_MATRIX
- Build.PL: require App::Dochazka::Common 0.191 for "set()" method
- Dispatch.pm: increase granularity of employee/.../minimal ACL check
- No longer auto-generate Makefile.PL
0.471 2015-07-23 16:55 CEST
- t/201-LDAP.t: add simple test cases for GET employee/nick/:nick/ldap
- ResourceDefs.pm: enable PUT on employee/nick/:nick/ldap
- LDAP.pm: fix populate_employee() so it returns not_ok if nick is not in LDAP
- Dispatch.pm: implement handler_get_employee_ldap and handler_put_employee_ldap
- Auth.pm: fix DOCHAZKA_LDAP_AUTOCREATE_AS code path
0.472 2015-07-24 17:06 CEST
- doc: config/REST_Config.pm: tell users to not add a nick property to
DOCHAZKA_LDAP_POPULATE_MATRIX
- t/: test POST employee/nick without required nick property
- Dispatch.pm: return 400 if POST employee/nick without nick property
(fixes github issue #2)
- Dispatch.pm: handler_put_employee_ldap() return 404 if nick not found in LDAP
------------------------------------------------------------------------
Implement site policy table
https://github.com/smithfarm/dochazka-rest/issues/25
The use case for a policy table is as follows: we have a site
configuration mechanism, but the SQL code cannot access it.
SQL-relevant configuration values, such as what constitutes "too far in
the future" for the not_too_future() stored procedure, could be stored
in a "policy" table and accessed via a Policy class.
The idea is that each policy would define a scalar value used in a
function or trigger. This would give site admins some degree of control
over the functions/triggers.
So, site admins would not be able to add or delete policies, but they
could update them. Each policy object would contain a validation
attribute defining the range of permissible values.
bin/dochazka-dbinit view on Meta::CPAN
$log->info( $message );
if ( ! $site->MREST_APPNAME ) {
die "Site parameter MREST_APPNAME is undefined - please investigate!";
}
$log->init(
ident => $site->MREST_APPNAME,
debug_mode => ( $site->MREST_DEBUG_MODE || 0 ),
);
$status = App::Dochazka::REST::reset_db();
if ( $status->not_ok ) {
die "PostgreSQL server is unreachable";
}
print "Dochazka database initialized\n";
bin/dochazka-ldap-sync-all view on Meta::CPAN
}
my $emp_list = $status->payload;
foreach ( @$emp_list ) {
if ( ! ldap_exists( $_->nick ) ) {
print "WARNING: " . $_->nick . " not found in LDAP database!\n" unless $quiet;
next;
}
my $old = $_->clone();
$status = $_->ldap_sync();
if ( $status->not_ok ) {
print "WARNING: could not sync " . $_->nick . " from LDAP\n" unless $quiet;
next;
}
if ( $old->compare( $_ ) ) {
print $_->nick . " existing profile data match LDAP: no action needed\n" unless $quiet;
next;
}
$status = $_->update( $faux_context );
if ( $status->ok ) {
print $_->nick . " profile updated from LDAP\n" unless $quiet;
config/sql/dbinit_Config.pm view on Meta::CPAN
RETURN 't'::boolean;
ELSE
RETURN 'f'::boolean;
END IF;
END;
$$ LANGUAGE plpgsql/,
q/COMMENT ON FUNCTION overlaps(tstzrange, tstzrange) IS
'Tests two tstzranges whether they overlap'/,
q/CREATE OR REPLACE FUNCTION not_before_1892(timestamptz)
RETURNS TIMESTAMPTZ AS $IMM$
BEGIN
IF $1 < '1892-01-01'::timestamptz THEN
RAISE EXCEPTION 'No dates earlier than 1892-01-01 please';
END IF;
RETURN $1;
END;
$IMM$ LANGUAGE plpgsql/,
q/COMMENT ON FUNCTION not_before_1892(timestamptz) IS 'We enforce dates 1892-01-01 or later'/,
q#CREATE OR REPLACE FUNCTION valid_intvl() RETURNS trigger AS $$
BEGIN
IF ( NEW.intvl IS NULL ) OR
( isempty(NEW.intvl) ) OR
( lower(NEW.intvl) = '-infinity' ) OR
( lower(NEW.intvl) = 'infinity' ) OR
( upper(NEW.intvl) = '-infinity' ) OR
( upper(NEW.intvl) = 'infinity' ) OR
( NOT lower_inc(NEW.intvl) ) OR
( upper_inc(NEW.intvl) ) OR
( lower_inf(NEW.intvl) ) OR
( upper_inf(NEW.intvl) ) THEN
RAISE EXCEPTION 'illegal attendance interval %s', NEW.intvl;
END IF;
PERFORM not_before_1892(upper(NEW.intvl));
PERFORM not_before_1892(lower(NEW.intvl));
IF ( upper(NEW.intvl) != round_time(upper(NEW.intvl)) ) OR
( lower(NEW.intvl) != round_time(lower(NEW.intvl)) ) THEN
RAISE EXCEPTION 'upper and lower bounds of interval must be evenly divisible by 5 minutes';
END IF;
RETURN NEW;
END;
$$ LANGUAGE plpgsql IMMUTABLE
#,
q#COMMENT ON FUNCTION valid_intvl() IS $body$
config/sql/dbinit_Config.pm view on Meta::CPAN
q/CREATE OR REPLACE FUNCTION round_effective() RETURNS trigger AS $$
BEGIN
NEW.effective = round_time(NEW.effective);
RETURN NEW;
END;
$$ LANGUAGE plpgsql IMMUTABLE/,
q/CREATE OR REPLACE FUNCTION sane_timestamp() RETURNS trigger AS $$
BEGIN
PERFORM not_before_1892(NEW.effective);
RETURN NEW;
END;
$$ LANGUAGE plpgsql IMMUTABLE/,
q/CREATE TRIGGER round_effective BEFORE INSERT OR UPDATE ON schedhistory
FOR EACH ROW EXECUTE PROCEDURE round_effective()/,
q/CREATE TRIGGER round_effective BEFORE INSERT OR UPDATE ON privhistory
FOR EACH ROW EXECUTE PROCEDURE round_effective()/,
config/sql/dbinit_Config.pm view on Meta::CPAN
WHERE eid=NEW.eid AND effective >= lower(NEW.intvl) AND effective <= upper(NEW.intvl);
IF sh_count > 0 THEN
RAISE EXCEPTION 'employee schedule for this interval cannot be determined';
END IF;
RETURN NEW;
END;
$$ LANGUAGE plpgsql IMMUTABLE/,
q/-- trigger function for use in sanity checks on attendance and lock intervals
-- vets an interval to ensure it does not extend too far into the future
CREATE OR REPLACE FUNCTION not_too_future() RETURNS trigger AS $$
DECLARE
limit_ts timestamptz;
BEGIN
--
-- does the interval extend too far into the future?
--
SELECT date_trunc('MONTH', (now() + interval '4 months'))::TIMESTAMPTZ INTO limit_ts;
IF upper(NEW.intvl) >= limit_ts THEN
RAISE EXCEPTION 'interval extends too far into the future';
END IF;
config/sql/dbinit_Config.pm view on Meta::CPAN
q/CREATE TRIGGER one_and_only_one_schedule BEFORE INSERT OR UPDATE ON intervals
FOR EACH ROW EXECUTE PROCEDURE schedule_policy()/,
q/CREATE TRIGGER enforce_priv_policy BEFORE INSERT OR UPDATE ON intervals
FOR EACH ROW EXECUTE PROCEDURE priv_policy()/,
q/CREATE TRIGGER a1_interval_valid_intvl BEFORE INSERT OR UPDATE ON intervals
FOR EACH ROW EXECUTE PROCEDURE valid_intvl()/,
q/CREATE TRIGGER a2_interval_not_too_future BEFORE INSERT OR UPDATE ON intervals
FOR EACH ROW EXECUTE PROCEDURE not_too_future()/,
q/CREATE TRIGGER a3_no_iid_update BEFORE UPDATE ON intervals
FOR EACH ROW EXECUTE PROCEDURE iid_immutable()/,
# the 'locks' table
q/-- locks
CREATE TABLE locks (
lid serial PRIMARY KEY,
eid integer REFERENCES Employees (EID),
config/sql/dbinit_Config.pm view on Meta::CPAN
IF OLD.lid <> NEW.lid THEN
RAISE EXCEPTION 'locks.lid field is immutable';
END IF;
RETURN NEW;
END;
$IMM$ LANGUAGE plpgsql/,
q/CREATE TRIGGER a1_lock_valid_intvl BEFORE INSERT OR UPDATE ON locks
FOR EACH ROW EXECUTE PROCEDURE valid_intvl()/,
q/CREATE TRIGGER a2_lock_not_too_future BEFORE INSERT OR UPDATE ON locks
FOR EACH ROW EXECUTE PROCEDURE not_too_future()/,
q/-- trigger the trigger
CREATE TRIGGER a3_no_lid_update BEFORE UPDATE ON locks
FOR EACH ROW EXECUTE PROCEDURE lid_immutable()/,
q/-- lock lookup trigger for intervals table
CREATE OR REPLACE FUNCTION no_lock_conflict() RETURNS trigger AS $IMM$
DECLARE
this_eid integer;
this_intvl tstzrange;
config/sql/dbinit_Config.pm view on Meta::CPAN
IF TG_OP = 'INSERT' OR TG_OP = 'UPDATE' THEN
RETURN NEW;
ELSE
RETURN OLD;
END IF;
END;
$IMM$ LANGUAGE plpgsql/,
q/CREATE TRIGGER intvl_not_locked BEFORE INSERT OR UPDATE OR DELETE ON intervals
FOR EACH ROW EXECUTE PROCEDURE no_lock_conflict()/,
# the 'tempintvls' table and associated plumbing
q/CREATE SEQUENCE temp_intvl_seq/,
q/COMMENT ON SEQUENCE temp_intvl_seq IS 'sequence guaranteeing that each set of temporary intervals will have a unique identifier'/,
q/-- tempintvls
-- for staging fillup intervals
CREATE TABLE IF NOT EXISTS tempintvls (
int_id serial PRIMARY KEY,
tiid integer NOT NULL,
intvl tstzrange NOT NULL
)/,
q/CREATE TRIGGER a2_interval_not_too_future BEFORE INSERT OR UPDATE ON tempintvls
FOR EACH ROW EXECUTE PROCEDURE not_too_future()/,
# create 'root' and 'demo' employees
q/-- insert root employee into employees table and grant admin
-- privilege to the resulting EID
WITH cte AS (
INSERT INTO employees (nick, fullname, email, passhash, salt, remark)
VALUES ('root', 'Root Immutable', 'root@site.org', '82100e9bd4757883b4627b3bafc9389663e7be7f76a1273508a7a617c9dcd917428a7c44c6089477c8e1d13e924343051563d2d426617b695f3a3bff74e7c003', '341755e03e1f163f829785d1d19eab9dee5135c0', 'dbinit')
RETURNING eid
)
lib/App/Dochazka/REST.pm view on Meta::CPAN
my $conn = App::Dochazka::REST::ConnBank::get_arbitrary_dbix_conn(
$dbname, $dbuser, $dbpass
);
print "done\n";
print "Initializing audit schema...";
$status = run_sql(
$conn,
@{ $site->DBINIT_AUDIT },
);
if ( $status->not_ok ) {
print Dumper( $status ), "\n";
return $status;
}
print "done\n";
print "Initializing public schema...";
$status = run_sql(
$conn,
@{ $site->DBINIT_CREATE },
);
if ( $status->not_ok ) {
print Dumper( $status ), "\n";
return $status;
}
print "done\n";
# get EID of root employee that was just created, since
# we will need it in the second round of SQL statements
my $eids = get_eid_of( $conn, "root", "demo" );
$site->set( 'DOCHAZKA_EID_OF_ROOT', $eids->{'root'} );
$site->set( 'DOCHAZKA_EID_OF_DEMO', $eids->{'demo'} );
lib/App/Dochazka/REST/ACL.pm view on Meta::CPAN
} elsif ( my $nick = $pl{'nick'} ) {
$log->debug( "acl_check_is_my_report: given nick $nick" );
$status = $emp->load_by_nick( $conn, $nick );
} elsif ( my $sec_id = $pl{'sec_id'} ) {
$log->debug( "acl_check_is_my_report: given sec_id $sec_id" );
$status = $emp->load_by_sec_id( $conn, $sec_id );
} else {
die "AAAGAAHHAHAHAAJJAJAJAHAHA! " . Dumper( \%pl );
}
if ( $status->not_ok ) {
$log->error( "acl_check_is_my_report: employee lookup failed (" . $status->text . ")" );
return 0;
}
$emp = $status->payload;
if ( defined($emp->supervisor) and defined($ce->eid) and $emp->supervisor eq $ce->eid ) {
$log->debug( "acl_check_is_my_report: I am the supervisor of ->" . $emp->nick . "<-" );
return 1;
}
lib/App/Dochazka/REST/Auth.pm view on Meta::CPAN
$log->info( "Detected authentication attempt from $nick, a known LDAP user" );
#$log->debug( "Password provided: $password" );
# - authenticate by LDAP bind
if ( ldap_auth( $nick, $password ) ) {
# successful LDAP auth: if the employee doesn't already exist in
# the database, possibly autocreate
$status = autocreate_employee( $dbix_conn, $nick );
return $status unless $status->ok;
} else {
return $CELL->status_not_ok( 'DOCHAZKA_EMPLOYEE_AUTH' );
}
# load the employee object
my $emp = App::Dochazka::REST::Model::Employee->load_by_nick( $dbix_conn, $nick )->payload;
die "missing employee object in _authenticate" unless ref($emp) eq "App::Dochazka::REST::Model::Employee";
return $CELL->status_ok( 'DOCHAZKA_EMPLOYEE_AUTH', payload => $emp );
}
# if not, authenticate against the password stored in the employee object.
else {
$log->notice( "Employee $nick not found in LDAP; reverting to internal auth" );
# - check if this employee exists in database
my $emp = nick_exists( $dbix_conn, $nick );
if ( ! defined( $emp ) or ! $emp->isa( 'App::Dochazka::REST::Model::Employee' ) ) {
$log->notice( "Rejecting login attempt from unknown user $nick" );
$self->mrest_declare_status( explanation => "Authentication failed for user $nick", permanent => 1 );
return $CELL->status_not_ok;
}
# - the password might be empty
$password = '' unless defined( $password );
my $passhash = $emp->passhash;
$passhash = '' unless defined( $passhash );
# - check password against passhash
my ( $ppr, $status );
try {
lib/App/Dochazka/REST/Auth.pm view on Meta::CPAN
algorithm => "SHA-512",
salt_hex => $emp->salt,
hash_hex => $emp->passhash,
);
} catch {
$status = $CELL->status_err( 'DOCHAZKA_PASSPHRASE_EXCEPTION', args => [ $_ ] );
};
if ( ref( $ppr ) ne 'Authen::Passphrase::SaltedDigest' ) {
$log->crit( "employee $nick has invalid passhash and/or salt" );
return $CELL->status_not_ok( 'DOCHAZKA_EMPLOYEE_AUTH' );
}
if ( $ppr->match( $password ) ) {
$log->notice( "Internal auth successful for employee $nick" );
return $CELL->status_ok( 'DOCHAZKA_EMPLOYEE_AUTH', payload => $emp );
} else {
$self->mrest_declare_status( explanation =>
"Internal auth failed for known employee $nick (mistyped password?)"
);
return $CELL->status_not_ok;
}
}
}
=head2 forbidden
This overrides the L<Web::Machine> method of the same name.
Authorization (ACL check) method.
lib/App/Dochazka/REST/Dispatch.pm view on Meta::CPAN
=head1 PACKAGE VARIABLES
This module uses some package variables, which are essentially constants, to do
its work.
=cut
my $fail = $CELL->status_not_ok;
my %iue_dispatch = (
'insert_employee' => \&shared_insert_employee,
'update_employee' => \&shared_update_employee,
);
=head1 FUNCTIONS
=cut
lib/App/Dochazka/REST/Dispatch.pm view on Meta::CPAN
sub handler_holiday_tsrange {
my ( $self, $pass ) = @_;
$log->debug( "Entering " . __PACKAGE__ . "::handler_holiday_tsrange, pass number $pass" );
# first pass
if ( $pass == 1 ) {
my $status = split_tsrange(
$self->context->{'dbix_conn'},
$self->context->{'mapping'}->{'tsrange'},
);
if ( $status->not_ok ) {
$status->{'http_code'} = ( $status->code eq 'DOCHAZKA_DBI_ERR' )
? 500
: 400;
$self->mrest_declare_status( $status );
return 0;
}
my $datereg = qr/(\d+-\d+-\d+)/;
my ( $begin ) = $status->payload->[0] =~ $datereg;
my ( $end ) = $status->payload->[1] =~ $datereg;
if ( ! defined( $begin ) or ! defined( $end ) ) {
lib/App/Dochazka/REST/Dispatch.pm view on Meta::CPAN
=head3 _ldap_sync_pass1
=cut
sub _ldap_sync_pass1 {
my ( $self, $emp ) = @_;
$log->debug( "Entering " . __PACKAGE__ . "::_ldap_sync_pass1" );
my $status = $emp->ldap_sync();
$log->debug( "ldap_sync status: " . Dumper( $status ) );
if ( $status->not_ok ) {
if ( $status->code eq 'DOCHAZKA_LDAP_SYSTEM_USER_NOSYNC' ) {
# system user - 403
$status->{'http_code'} = 403;
} else {
$status->{'http_code'} = 404;
}
$self->mrest_declare_status( $status );
return 0;
}
$self->context->{'stashed_employee_object'} = $emp;
lib/App/Dochazka/REST/Dispatch.pm view on Meta::CPAN
keys => [ $key ],
);
# check for 404
if ( $status->level eq 'NOTICE' and $status->code eq 'DISPATCH_NO_RECORDS_FOUND' ) {
$self->mrest_declare_status( code => 404,
explanation => "DISPATCH_SEARCH_EMPTY",
args => [ 'employee', "nick LIKE $key" ],
);
return $fail;
}
return $status if $status->not_ok;
# found some employee objects
foreach my $emp ( @{ $status->payload } ) {
$emp = $emp->TO_JSON;
}
return $status;
}
=head2 Genreport handlers
lib/App/Dochazka/REST/Dispatch.pm view on Meta::CPAN
die "BGUDFUUFF! Improper prop ->$prop<- seen!";
}
# - process return value
if ( $status->level eq 'NOTICE' and $status->code eq 'DISPATCH_NO_RECORDS_FOUND' ) {
my $tsmsg = ( $ts ) ? $ts : 'now';
$self->mrest_declare_status(
code => 404,
explanation => "No $prop history for $key $value as of $tsmsg",
);
return $fail;
} elsif ( $status->not_ok ) {
$self->mrest_declare_status(
code => 500,
explanation => $status->text,
);
return $fail;
}
return $status;
}
lib/App/Dochazka/REST/Dispatch.pm view on Meta::CPAN
$prop,
$context->{'dbix_conn'},
eid => $emp->eid,
nick => $emp->nick,
tsrange => $tsrange,
);
# - process return value
if ( $status->level eq 'NOTICE' and $status->code eq 'DISPATCH_NO_RECORDS_FOUND' ) {
$self->mrest_declare_status( code => 404, explanation => "No history for $key $value $tsrange" );
return $fail;
} elsif ( $status->not_ok ) {
$self->mrest_declare_status( code => 500, explanation => $status->text );
return $fail;
}
return $status;
}
=head3 handler_history_post
Handler method for POST requests on the '/{priv,schedule}/history/eid/..' and
lib/App/Dochazka/REST/Dispatch.pm view on Meta::CPAN
eid => $emp->eid,
effective => $entity->{'effective'},
$prop => $entity->{$prop},
remark => $entity->{'remark'},
);
} catch {
$log->crit($_);
return $CELL->status_crit("DISPATCH_HISTORY_COULD_NOT_SPAWN", args => [ $_ ] );
};
$status = $ho->insert( $context );
if ( $status->not_ok ) {
$self->context->{'create_path'} = $status->level;
if ( $status->code eq 'DOCHAZKA_MALFORMED_400' ) {
return $self->mrest_declare_status(
code => 400,
explanation => "Check syntax of your request entity"
);
}
return $self->mrest_declare_status(
code => 500,
explanation => $status->code,
lib/App/Dochazka/REST/Dispatch.pm view on Meta::CPAN
my $context = $self->context;
# first pass
if ( $pass == 1 ) {
$context->{'post_is_create'} = 1;
return 1;
}
# second pass
my $status = shared_entity_check( $self, 'aid', 'intvl' );
return $fail if $status->not_ok;
if ( check_acl_context( $context )->not_ok ) {
$self->mrest_declare_status( code => 403, explanation => 'DISPATCH_KEEP_TO_YOURSELF' );
return $fail;
}
return shared_insert_interval( $self );
}
=head3 handler_post_interval_iid
lib/App/Dochazka/REST/Dispatch.pm view on Meta::CPAN
my $context = $self->context;
# first pass
if ( $pass == 1 ) {
$context->{'post_is_create'} = 1;
return 1;
}
# second pass
my $status = shared_entity_check( $self, 'intvl' );
return $fail if $status->not_ok;
if ( check_acl_context( $context )->not_ok ) {
$self->mrest_declare_status( code => 403, explanation => 'DISPATCH_KEEP_TO_YOURSELF' );
return $fail;
}
return shared_insert_lock( $self );
}
=head3 handler_post_lock_lid
lib/App/Dochazka/REST/Dispatch.pm view on Meta::CPAN
if ( ! $fillup->constructor_status or
! $fillup->constructor_status->isa( 'App::CELL::Status' ) )
{
$self->mrest_declare_status(
code => 500,
explanation => "No constructor_status in Fillup object"
);
return $fail;
}
$log->debug( "Fillup object created; constructor status is " . Dumper( $fillup->constructor_status ) );
if ( $fillup->constructor_status->not_ok ) {
my $status = $fillup->constructor_status;
$status->{'http_code'} = ( $status->code eq 'DOCHAZKA_DBI_ERR' )
? 500
: 400;
$self->mrest_declare_status( $status );
return $fail;
}
my $status = $fillup->commit;
if ( $status->not_ok ) {
$self->mrest_declare_status( code => 500, explanation => $status->text );
return $fail;
}
return $status;
}
# helper function to extract employee spec from request entity
# takes request entity hash and returns either undef on failure
# or Employee object on success
sub _extract_employee_spec {
lib/App/Dochazka/REST/Dispatch.pm view on Meta::CPAN
# first pass
if ( $pass == 1 ) {
$context->{'post_is_create'} = 1;
return 1;
}
# second pass
my ( $status, $code );
$status = shared_entity_check( $self, 'schedule' );
return $fail if $status->not_ok;
if ( ref( $context->{'request_entity'}->{'schedule'} ) ne "ARRAY" ) {
$self->mrest_declare_status( code => 400, explanation => 'Check schedule syntax' );
return $fail;
}
# first, spawn a Schedintvls object
my $intvls = App::Dochazka::REST::Model::Schedintvls->spawn;
$log->debug( "Spawned Schedintvls object " . Dumper( $intvls ) );
# note that a SSID has been assigned
my $ssid = $intvls->ssid;
$log->debug("Spawned Schedintvls object with SSID $ssid");
# assume that these are the intervals
$intvls->{'intvls'} = $context->{'request_entity'}->{'schedule'};
#
# insert the intervals
$status = $intvls->insert( $context->{'dbix_conn'} ); # schedintvls is not audited
if ( $status->not_ok ) {
$self->mrest_declare_status( code => 500, explanation => $status->text );
return $fail;
}
$log->info( "schedule/new: Scratch intervals inserted" );
#
# convert the intervals to get the 'schedule' property
$status = $intvls->load( $context->{'dbix_conn'} );
if ( $status->not_ok ) {
$intvls->delete( $context->{'dbix_conn'} );
$self->mrest_declare_status( code => 400, explanation => $status->text );
return $fail;
}
$log->info( "schedule/new: Scratch intervals converted" );
#
# spawn Schedule object
my @ARGS = ( 'schedule' => $intvls->json );
if ( my $scode = $context->{'request_entity'}->{'scode'} ) {
lib/App/Dochazka/REST/Dispatch.pm view on Meta::CPAN
}
} else {
$self->mrest_declare_status( code => 500, explanation =>
"schedule/new: Model/Schedule.pm->insert failed: " . $status->text );
$intvls->delete( $context->{'dbix_conn'} );
return $fail;
}
#
# delete the schedintvls object
$status = $intvls->delete( $context->{'dbix_conn'} ); # schedintvls is not audited
if ( $status->not_ok ) {
$self->mrest_declare_status( code => 500, explanation => "Could not delete schedintvls: " . $status->text );
return $fail;
}
$log->info( "schedule/new: scratch intervals deleted" );
#
# success
return $CELL->status_ok( $code, payload => $sched->TO_JSON );
}
lib/App/Dochazka/REST/Fillup.pm view on Meta::CPAN
Performs various tests on the C<context> attribute. If the value of that
attribute is not what we're expecting, returns a non-OK status. Otherwise,
returns an OK status.
=cut
sub _vet_context {
my $self = shift;
my %ARGS = @_;
return $CELL->status_not_ok unless $ARGS{context};
return $CELL->status_not_ok unless $ARGS{context}->{dbix_conn};
return $CELL->status_not_ok unless $ARGS{context}->{dbix_conn}->isa('DBIx::Connector');
$self->context( $ARGS{context} );
$self->{'vetted'}->{'context'} = 1;
return $CELL->status_ok;
}
=head2 _vet_date_spec
The user can specify fillup dates either as a tsrange or as a list of
individual dates.
lib/App/Dochazka/REST/Fillup.pm view on Meta::CPAN
=cut
sub _vet_date_spec {
my $self = shift;
my %ARGS = @_;
$log->debug( "Entering " . __PACKAGE__ . "::_vet_date_spec to enforce date specification policy" );
if ( defined( $ARGS{date_list} ) and defined( $ARGS{tsrange} ) ) {
$log->debug( "date_spec is NOT OK" );
return $CELL->status_not_ok;
}
if ( ! defined( $ARGS{date_list} ) and ! defined( $ARGS{tsrange} ) ) {
$log->debug( "date_spec is NOT OK" );
return $CELL->status_not_ok;
}
$self->{'vetted'}->{'date_spec'} = 1;
$log->debug( "date_spec is OK" );
return $CELL->status_ok;
}
=head2 _vet_date_list
This function takes one named argument: date_list, the value of which must
lib/App/Dochazka/REST/Model/Employee.pm view on Meta::CPAN
$count += 1;
}
$ldap->unbind;
return $CELL->status_ok(
'DOCHAZKA_LDAP_SYNC_SUCCESS',
args => [ $count ],
) unless $count < 1;
return $CELL->status_not_ok( 'DOCHAZKA_LDAP_SYNC_FAILURE' );
}
=head2 load_by_eid
Analogous method to L<App::Dochazka::REST::Model::Activity/"load_by_aid">.
=cut
sub load_by_eid {
lib/App/Dochazka/REST/Model/Employee.pm view on Meta::CPAN
create the employee. Returns a status object.
=cut
sub autocreate_employee {
my ( $dbix_conn, $nick ) = @_;
$log->debug( "Entering " . __PACKAGE__ . "::autocreate_employee()" );
my $status;
return $CELL->status_ok() if nick_exists( $dbix_conn, $nick );
return $CELL->status_not_ok( 'DOCHAZKA_NO_AUTOCREATE' ) unless $site->DOCHAZKA_LDAP_AUTOCREATE;
my $emp = App::Dochazka::REST::Model::Employee->spawn(
nick => $nick,
sync => 1,
remark => 'LDAP autocreate',
);
$status = $emp->ldap_sync();
return $status unless $status->ok;
my $faux_context = { 'dbix_conn' => $dbix_conn, 'current' => { 'eid' => 1 } };
$status = $emp->insert( $faux_context );
if ( $status->not_ok ) {
my $reason = $status->text;
return $CELL->status_err(
'DOCHAZKA_EMPLOYEE_CREATE_FAIL',
args => [ $nick, $reason ],
);
}
$log->notice( "Auto-created employee $nick, who was authenticated via LDAP" );
my $priv = $site->DOCHAZKA_LDAP_AUTOCREATE_AS;
if ( $priv !~ m/^(inactive)|(active)$/ ) {
lib/App/Dochazka/REST/Model/Employee.pm view on Meta::CPAN
# create a privhistory record (inactive/active only)
init_timepiece();
my $ph_obj = App::Dochazka::REST::Model::Privhistory->spawn(
eid => $emp->eid,
priv => $priv,
effective => ( $today . ' 00:00' ),
remark => 'LDAP autocreate',
);
$status = $ph_obj->insert( $faux_context );
if ( $status->not_ok ) {
my $reason = $status->text;
$status = $CELL->status_err(
'DOCHAZKA_AUTOCREATE_PRIV_PROBLEM',
args => [ $nick, $reason ],
);
}
return $status;
}
lib/App/Dochazka/REST/Shared.pm view on Meta::CPAN
use App::Dochazka::REST::Model::Lock;
use App::Dochazka::REST::Model::Privhistory;
use App::Dochazka::REST::Model::Schedhistory;
use App::Dochazka::REST::Model::Schedule;
use App::Dochazka::REST::Model::Shared qw( priv_by_eid schedule_by_eid );
use App::Dochazka::REST::Util qw( hash_the_password pre_update_comparison );
use Data::Dumper;
use Params::Validate qw( :all );
use Try::Tiny;
my $fail = $CELL->status_not_ok;
=head1 NAME
App::Dochazka::REST::Dispatch::Shared - Shared dispatch functions
=head1 DESCRIPTION
lib/App/Dochazka/REST/Shared.pm view on Meta::CPAN
die "shared_first_pass_lookup could not do anything with key $key!";
}
if ( $status->level eq 'NOTICE' and $status->code eq 'DISPATCH_NO_RECORDS_FOUND' ) {
$d_obj->mrest_declare_status( code => 404,
explanation => 'DISPATCH_SEARCH_EMPTY',
args => [ $thing, "$key equals $value" ],
);
return;
}
if ( $status->not_ok ) {
$d_obj->mrest_declare_status( code => 500, explanation => $status->code,
args => $status->args
);
return;
}
return $status->payload;
}
=head2 shared_entity_check
lib/App/Dochazka/REST/Shared.pm view on Meta::CPAN
$return_value = $status->payload;
}
my @privsched = ( $t, $return_value );
if ( $ts ) {
if ( ! $return_value ) {
$d_obj->mrest_declare_status(
code => 404,
explanation => "Employee $nick (EID $eid) has no $t assigned as of $ts"
);
return $CELL->status_not_ok;
}
my $code;
if ( 'PRIV' eq uc( $t ) ) {
$code = 'DISPATCH_EMPLOYEE_PRIV_AS_AT';
} elsif ( 'SCHEDULE' eq uc( $t ) ) {
$code = 'DISPATCH_EMPLOYEE_SCHEDULE_AS_AT';
} else {
die "AGHNEVERNEVERNEVERPRIVSCHED1";
}
return $CELL->status_ok( $code,
lib/App/Dochazka/REST/Shared.pm view on Meta::CPAN
timestamp => $ts,
@privsched,
},
);
} else {
if ( ! $return_value ) {
$d_obj->mrest_declare_status(
code => 404,
explanation => "Employee $nick (EID $eid) has no $t assigned"
);
return $CELL->status_not_ok;
}
my $code;
if ( 'PRIV' eq uc( $t ) ) {
$code = 'DISPATCH_EMPLOYEE_PRIV';
} elsif ( 'SCHEDULE' eq uc( $t ) ) {
$code = 'DISPATCH_EMPLOYEE_SCHEDULE';
} else {
die "AGHNEVERNEVERNEVERPRIVSCHED2";
}
return $CELL->status_ok( $code,
lib/App/Dochazka/REST/Test.pm view on Meta::CPAN
note( "Set log level" );
$log->init(
ident => $site->MREST_APPNAME,
debug_mode => 1,
);
note( "Initialize" );
try {
App::Dochazka::REST::Dispatch::init();
} catch {
$status = $CELL->status_not_ok;
};
plan skip_all => 'Integration testing environment not detected' unless $status->ok;
note( "Check status of database server connection" );
plan skip_all => "PostgreSQL server is unreachable" unless conn_up();
my $eids = App::Dochazka::REST::get_eid_of( $dbix_conn, "root", "demo" );
$site->set( 'DOCHAZKA_EID_OF_ROOT', $eids->{'root'} );
$site->set( 'DOCHAZKA_EID_OF_DEMO', $eids->{'demo'} );
lib/App/Dochazka/REST/Test.pm view on Meta::CPAN
my ( $PROPS ) = validate_pos( @_,
{ type => HASHREF },
);
hash_the_password( $PROPS );
my $emp = App::Dochazka::REST::Model::Employee->spawn( $PROPS );
is( ref($emp), 'App::Dochazka::REST::Model::Employee', 'create_bare_employee 1' );
my $status = $emp->insert( $faux_context );
if ( $status->not_ok ) {
diag( "Employee insert method returned NOT_OK status in create_bare_employee" );
diag( "test automation function, which was called from " . (caller)[1] . " line " . (caller)[2] );
diag( "with arguments: " . Dumper( $PROPS ) );
diag( "Full status returned by employee insert method:" );
diag( Dumper $status );
BAIL_OUT(0);
}
is( $status->level, "OK", 'create_bare_employee 2' );
my $employee_object = $status->payload;
is( ref( $employee_object ), 'App::Dochazka::REST::Model::Employee' );
lib/App/Dochazka/REST/Test.pm view on Meta::CPAN
Takes a single argument: the EID.
Loads the EID into a new Employee object and calls that object's delete method.
=cut
sub delete_bare_employee {
my $eid = shift;
note( "delete testing employee with EID $eid" );
my $status = App::Dochazka::REST::Model::Employee->load_by_eid( $dbix_conn, $eid );
if ( $status->not_ok ) {
diag( "Employee load_by_eid method returned NOT_OK status in delete_bare_employee" );
diag( "test automation function, which was called from " . (caller)[1] . " line " . (caller)[2] );
diag( "with EID $eid" );
diag( "Full status returned by Employee load_by_eid method:" );
diag( Dumper $status );
BAIL_OUT(0);
}
is( $status->level, 'OK', 'delete_bare_employee 1' );
my $emp = $status->payload;
$status = $emp->delete( $faux_context );
if ( $status->not_ok ) {
diag( Dumper $status );
BAIL_OUT(0);
}
is( $status->level, 'OK', 'delete_bare_employee 2' );
return;
}
sub _create_employee {
my ( $test, $privspec ) = @_;
lib/App/Dochazka/REST/Test.pm view on Meta::CPAN
Tests will need to set up and tear down testing activities
=cut
sub create_testing_activity {
my %PROPS = @_; # must be at least code
my $act = App::Dochazka::REST::Model::Activity->spawn( \%PROPS );
is( ref($act), 'App::Dochazka::REST::Model::Activity', 'create_testing_activity 1' );
my $status = $act->insert( $faux_context );
if ( $status->not_ok ) {
BAIL_OUT( $status->code . " " . $status->text );
}
is( $status->level, "OK", 'create_testing_activity 2' );
return $status->payload;
}
=head2 delete_testing_activity
Tests will need to set up and tear down testing activities
lib/App/Dochazka/REST/Test.pm view on Meta::CPAN
Tests will need to set up and tear down testing intervals
=cut
sub create_testing_interval {
my %PROPS = @_; # must be at least code
my $act = App::Dochazka::REST::Model::Interval->spawn( \%PROPS );
is( ref($act), 'App::Dochazka::REST::Model::Interval', 'create_testing_interval 1' );
my $status = $act->insert( $faux_context );
if ( $status->not_ok ) {
BAIL_OUT( $status->code . " " . $status->text );
}
is( $status->level, "OK", 'create_testing_interval 2' );
return $status->payload;
}
=head2 delete_testing_interval
Tests will need to set up and tear down testing intervals
lib/App/Dochazka/REST/Test.pm view on Meta::CPAN
Tests will need to set up and tear down testing components
=cut
sub create_testing_component {
my %PROPS = @_; # must be at least path
my $comp = App::Dochazka::REST::Model::Component->spawn( \%PROPS );
is( ref($comp), 'App::Dochazka::REST::Model::Component', 'create_testing_component 1' );
my $status = $comp->insert( $faux_context );
if ( $status->not_ok ) {
BAIL_OUT( $status->code . " " . $status->text );
}
is( $status->level, "OK", 'create_testing_component 2' );
return $status->payload;
}
=head2 delete_testing_component
Tests will need to set up and tear down testing components
lib/App/Dochazka/REST/Test.pm view on Meta::CPAN
=cut
sub delete_testing_schedule {
my ( $sid ) = @_;
note( "delete testing schedule (SID $sid)" );
my $status = App::Dochazka::REST::Model::Schedule->load_by_sid( $dbix_conn, $sid );
is( $status->level, 'OK', 'delete_testing_schedule: load OK' );
if ( $status->not_ok ) {
diag( Dumper $status );
BAIL_OUT(0);
}
my $sched = $status->payload;
$status = $sched->delete( $faux_context );
is( $status->level, 'OK', 'delete_testing_schedule: delete OK' );
if ( $status->not_ok ) {
diag( Dumper $status );
BAIL_OUT(0);
}
return;
}
=head2 delete_all_attendance_data
Wipe out all attendance data by deleting all rows from all tables (in the correct
t/001-noauto.t view on Meta::CPAN
use strict;
use warnings;
#use App::CELL::Test::LogToFile;
use App::CELL qw( $site );
use Test::More;
use Web::MREST;
note( 'initialize the REST server' );
my $status = Web::MREST::init( distro => 'App-Dochazka-REST' );
if ( $status->not_ok ) {
diag( $status->text );
plan skip_all => "Not configured. Please run the test suite manually after initial site configuration";
}
note( 'DOCHAZKA_TIMEZONE must be set' );
BAIL_OUT(-1) unless $site->DOCHAZKA_TIMEZONE;
ok( 1 );
done_testing;
t/dispatch/activity.t view on Meta::CPAN
note( "root: fail invalid code" );
req( $test, 400, 'root', 'DELETE', "$base/!!!" );
note( "delete FOOBARPUS, too" );
$status = req( $test, 200, 'root', 'DELETE', "$base/foobarpus" );
is( $status->level, 'OK', "DELETE $base/foobarpus 2" );
is( $status->code, 'DOCHAZKA_CUD_OK', "DELETE $base/foobarpus 3" );
note( "teardown" );
$status = delete_all_attendance_data();
if ( $status->not_ok ) {
diag( Dumper $status );
BAIL_OUT(0);
}
done_testing;
t/dispatch/employee.t view on Meta::CPAN
note( "looping: POST $base" );
note( "- default configuration is that 'active' and 'inactive' can modify" );
note( ' their own passhash and salt fields; demo should *not* be ' );
note( ' authorized to do this' );
req( $test, 403, 'demo', 'POST', $base, '{ "password":"saltine" }' );
foreach my $user ( "active", "inactive" ) {
#
#diag( "$user $base " . '{ "password" : "saltine" }' );
$status = req( $test, 200, $user, 'POST', $base, '{ "password" : "saltine" }' );
if ( $status->not_ok ) {
diag( Dumper $status );
BAIL_OUT(0);
}
is( $status->level, 'OK' );
is( $status->code, 'DOCHAZKA_CUD_OK' );
note( '- use root to change it back, otherwise the user won\'t be able' );
note( ' to log in and next tests will fail' );
$status = req( $test, 200, 'root', 'PUT', "employee/nick/$user", "{ \"password\" : \"$user\" }" );
is( $status->level, 'OK' );
t/dispatch/history.t view on Meta::CPAN
note( 'we will be inserting a bunch of records so push them onto an array' );
note( 'for easy deletion later' );
my @history_recs_to_delete;
# - be nice
$j = ( $base =~ m/^priv/ )
? '{ "effective":"1969-04-28 19:15", "priv":"inactive" }'
: '{ "effective":"1969-04-28 19:15", "sid":' . $ts_sid . ' }';
req( $test, 403, 'demo', 'POST', "$base/2", $j );
$status = req( $test, 201, 'root', 'POST', "$base/2", $j );
if ( $status->not_ok ) {
diag( $status->code . ' ' . $status->text );
}
is( $status->level, 'OK' );
my $pho = $status->payload;
my $prop = ( $base =~ m/^priv/ ) ? 'phid' : 'shid';
ok( exists $pho->{$prop}, "$prop exists in payload after POST $base/2" );
ok( defined $pho->{$prop}, "$prop defined in payload after POST $base/2" );
push @history_recs_to_delete, { eid => $pho->{eid}, $prop => $pho->{$prop} };
note( 'be pathological' );
t/dispatch/history.t view on Meta::CPAN
note( 'PUT' );
req( $test, 405, 'demo', 'PUT', "$base/asdf" );
req( $test, 405, 'root', 'PUT', "$base/asdf" );
note( "POST" );
$j = ( $base =~ m/^priv/ )
? '{ "effective":"1969-04-27 9:45", "priv":"inactive" }'
: '{ "effective":"1969-04-27 9:45", "sid":' . $ts_sid . ' }';
req( $test, 403, 'demo', 'POST', "$base/demo", $j );
$status = req( $test, 201, 'root', 'POST', "$base/demo", $j );
if ( $status->not_ok ) {
diag( $status->code . ' ' . $status->text );
}
is( $status->level, 'OK' );
my $pho = $status->payload;
my $prop = ( $base =~ m/^priv/ ) ? 'phid' : 'shid';
push my @history_recs_to_delete, { nick => 'demo', $prop => $pho->{$prop} };
note( 'DELETE' );
req( $test, 405, 'demo', 'DELETE', "$base/madagascar" );
req( $test, 405, 'active', 'DELETE', "$base/madagascar" );
t/dispatch/interval_lock.t view on Meta::CPAN
# req( $test, 403, $user, 'DELETE', "$base/2/[,)" );
#}
}
note( 'create an interval as active employee' );
my $aid_of_work = get_aid_by_code( $test, 'WORK' );
my $iae_interval_long_desc = 'iae interval';
$status = req( $test, 201, 'active', 'POST', 'interval/new', <<"EOH" );
{ "aid" : $aid_of_work, "intvl" : "[1958-01-02 08:00, 1958-01-03 08:00)", "long_desc" : "$iae_interval_long_desc" }
EOH
if ( $status->not_ok ) {
diag( "MARK iae active" );
diag( Dumper $status );
BAIL_OUT(0);
}
is( $status->level, 'OK' );
is( $status->code, 'DOCHAZKA_CUD_OK' );
ok( $status->{'payload'} );
ok( $status->{'payload'}->{'iid'} );
my $iae_iid = $status->payload->{'iid'}; # store for later deletion
t/dispatch/interval_lock.t view on Meta::CPAN
#
note( 'test if expected behavior behaves as expected (update)' );
my $int_obj = <<"EOH";
{ "$idmap{$il}" : $test_id, "remark" : "Sharpening pencils" }
EOH
req( $test, 403, 'demo', 'POST', $base, $int_obj );
req( $test, 403, 'inactive', 'POST', $base, $int_obj );
if ( $il eq 'interval' ) {
$status = req( $test, 200, 'active', 'POST', $base, $int_obj );
if ( $status->not_ok ) {
diag( "MARK foo1" );
diag( Dumper $status );
BAIL_OUT(0);
}
is( $status->level, 'OK', "POST $base 3" );
is( $status->code, 'DOCHAZKA_CUD_OK', "POST $base 4" );
is( $status->payload->{'iid'}, $test_iid, "POST $base 5" );
is( $status->payload->{'remark'}, 'Sharpening pencils', "POST $base 7" );
} else {
req( $test, 403, 'active', 'POST', $base, $int_obj );
t/dispatch/interval_lock.t view on Meta::CPAN
req( $test, 403, $user, 'POST', $base, <<"EOH" );
{ "aid" : $aid_of_work, "intvl" : "[1957-01-02 08:00, 1957-01-03 08:00)" }
EOH
}
note( '- let active and root create themselves an interval and promptly delete it' );
foreach my $user ( qw( active root ) ) {
$status = req( $test, 201, $user, 'POST', $base, <<"EOH" );
{ "aid" : $aid_of_work, "intvl" : "[1957-01-02 08:00, 1957-01-03 08:00)" }
EOH
if ( $status->not_ok ) {
diag( "MARK foo3 $user" );
diag( Dumper $status );
BAIL_OUT(0);
}
is( $status->level, 'OK' );
is( $status->code, 'DOCHAZKA_CUD_OK' );
ok( $status->{'payload'} );
ok( $status->{'payload'}->{'iid'} );
my $iid = $status->payload->{'iid'};
t/dispatch/interval_lock.t view on Meta::CPAN
}
note( '- as long as all required properties are present, JSON with bogus properties' );
note( ' will be accepted for insert operation (bogus properties will be silently ignored)' );
foreach my $rb (
"{ \"aid\" : $aid_of_work, \"intvl\" : \"[1957-01-02 08:00, 1957-01-02 08:05)\", \"whinger\" : \"me\" }",
"{ \"aid\" : $aid_of_work, \"intvl\" : \"[1957-01-03 08:00, 1957-01-03 08:05)\", \"horse\" : \"E-Or\" }",
"{ \"aid\" : $aid_of_work, \"intvl\" : \"[1957-01-04 08:00, 1957-01-04 08:05)\", \"nine dogs\" : [ 1, 9 ] }",
) {
$status = req( $test, 201, 'root', 'POST', $base, $rb );
if ( $status->not_ok ) {
diag( "MARK foo4: $rb");
diag( Dumper $status );
BAIL_OUT(0);
}
is( $status->level, 'OK' );
is( $status->code, 'DOCHAZKA_CUD_OK' );
ok( $status->{'payload'} );
ok( $status->{'payload'}->{'iid'} );
my $iid = $status->payload->{'iid'};
t/dispatch/interval_lock.t view on Meta::CPAN
{ "intvl" : "[1957-01-02 00:00, 1957-01-03 24:00)" }
EOH
}
note( 'let active and root create themselves a lock' );
foreach my $user ( qw( active root ) ) {
note( 'user == "active"' );
$status = req( $test, 201, $user, 'POST', $base, <<"EOH" );
{ "intvl" : "[1957-01-02 00:00, 1957-01-03 24:00)" }
EOH
if ( $status->not_ok ) {
diag( "MARK foo5" );
diag( Dumper $status );
BAIL_OUT(0);
}
is( $status->level, 'OK' );
is( $status->code, 'DOCHAZKA_CUD_OK' );
ok( $status->{'payload'} );
ok( $status->{'payload'}->{'lid'} );
my $lid = $status->payload->{'lid'};
note( "$user successfully created a lock" );
t/dispatch/interval_lock.t view on Meta::CPAN
}
note( 'as long as all required properties are present, JSON with bogus properties' );
note( 'will be accepted for insert operation (bogus properties will be silently ignored)' );
foreach my $rb (
"{ \"intvl\" : \"[1957-01-02 00:00, 1957-01-02 24:00)\", \"whinger\" : \"me\" }",
"{ \"intvl\" : \"[1957-01-03 00:00, 1957-01-03 24:00)\", \"horse\" : \"E-Or\" }",
"{ \"intvl\" : \"[1957-01-04 00:00, 1957-01-04 24:00)\", \"nine dogs\" : [ 1, 9 ] }"
) {
$status = req( $test, 201, 'root', 'POST', $base, $rb );
if ( $status->not_ok ) {
diag( "MARK foo6" );
diag( Dumper $status );
BAIL_OUT(0);
}
is( $status->level, 'OK' );
is( $status->code, 'DOCHAZKA_CUD_OK' );
ok( $status->{'payload'} );
ok( $status->{'payload'}->{'lid'} );
my $lid = $status->payload->{'lid'};
t/dispatch/interval_lock.t view on Meta::CPAN
#note( 'DELETE' );
#foreach my $user ( 'demo', 'root', 'WAMBLE owdkmdf 5**' ) {
# req( $test, 403, $user, 'DELETE', "$base/demo/[,)" );
#}
note( 'create an interval as active employee' );
my $ian_interval_long_desc = 'ian interval';
$status = req( $test, 201, 'active', 'POST', 'interval/new', <<"EOH" );
{ "aid" : $aid_of_work, "intvl" : "[1958-01-02 08:00, 1958-01-03 08:00)", "long_desc" : "$ian_interval_long_desc" }
EOH
if ( $status->not_ok ) {
diag( "MARK ian active" );
diag( Dumper $status );
BAIL_OUT(0);
}
is( $status->level, 'OK' );
is( $status->code, 'DOCHAZKA_CUD_OK' );
ok( $status->{'payload'} );
ok( $status->{'payload'}->{'iid'} );
my $ian_iid = $status->payload->{'iid'}; # store for later deletion
qr/was not a.*it is a/
);
like(
exception { $fo->emp_obj( $CELL->status_ok ) },
qr/was not a.*it is a/
);
note( $note = "vet empty context" );
$log->info( "=== $note" );
$status = $fo->_vet_context();
ok( $status->not_ok );
note( $note = "populate context attribute" );
$log->info( "=== $note" );
$status = $fo->_vet_context( context => $faux_context );
ok( $status->ok );
note( $note = "context should now be OK" );
$log->info( "=== $note" );
ok( $fo->context );
is( ref( $fo->context ), 'HASH' );
);
ok( $status->ok );
$status = $fo->_vet_date_spec(
tsrange => 'bubba', # can be any scalar, not necessarily a valid tsrange
);
ok( $status->ok );
$status = $fo->_vet_date_spec(
date_list => [ qw( 2016-01-01 2016-01-02 2016-01-03 ) ],
tsrange => 'bubba', # can be any scalar, not necessarily a valid tsrange
);
ok( $status->not_ok );
$status = $fo->_vet_date_spec();
ok( $status->not_ok );
$status = $fo->_vet_date_spec(
date_list => undef,
tsrange => undef,
);
ok( $status->not_ok );
isnt( $fo->context, undef );
note( $note = 'vet some valid date lists' );
$log->info( "=== $note" );
note( $note = 'valid date list #1' );
$log->info( "=== $note" );
reset_obj( $fo );
is( $fo->date_list, undef );
is( $fo->tsrange, undef );
my $ins_effective = "1892-01-01";
my $ins_remark = 'TESTING';
my $priv = App::Dochazka::REST::Model::Privhistory->spawn(
eid => $ins_eid,
priv => $ins_priv,
effective => $ins_effective,
remark => $ins_remark,
);
is( $priv->phid, undef, "phid undefined before INSERT" );
$status = $priv->insert( $faux_context );
diag( Dumper $status->text ) if $status->not_ok;
ok( $status->ok, "Post-insert status ok" );
ok( $priv->phid > 0, "INSERT assigned an phid" );
is( $priv->remark, $ins_remark, "remark survived INSERT" );
push my @phids_to_delete, $priv->phid;
note( $note = 'vet active - no schedule' );
$log->info( "=== $note" );
$status = $fo->_vet_employee( emp_obj => $active );
is( $status->level, 'ERR' );
is( $status->code, 'DISPATCH_EMPLOYEE_NO_SCHEDULE' );
'sync' => 1,
);
my $root_obj = App::Dochazka::REST::Model::Employee->spawn(
'nick' => 'root',
'sync' => 1,
);
note( "System users cannot be synced from LDAP" );
$emp = $root_obj->clone();
$status = $emp->ldap_sync();
ok( $status->not_ok, "Employee sync operation failed" );
is( $status->code, 'DOCHAZKA_LDAP_SYSTEM_USER_NOSYNC', "and for the right reason" );
note( "Test that existing LDAP user can be synced" );
note( "------------------------------------------" );
note( "1. assert that $ex employee object has non-nick properties unpopulated" );
$emp = $ex_obj->clone();
my @props = grep( !/^nick/, keys( %{ $site->DOCHAZKA_LDAP_MAPPING } ) );
foreach my $prop ( @props ) {
is( $emp->{$prop}, undef, "$prop property is undef" );
foreach my $prop ( @props ) {
ok( $emp->{$prop}, "$prop property has value " . $emp->{$prop} );
}
note( "Test that non-existing LDAP user can *not* be synced" );
note( "----------------------------------------------------" );
note( "1. populate $noex employee object from LDAP: fail" );
$emp = $noex_obj->clone();
$status = $emp->ldap_sync();
ok( $status->not_ok );
note( '####################################################' );
note( 'DISPATCH TESTS' );
note( '####################################################' );
note( "GET employee/nick/$noex/ldap returns 404" );
req( $test, 404, 'root', 'GET', "employee/nick/$noex/ldap" );
note( "PUT employee/nick/$noex/ldap returns 404" );
t/model/activity.t view on Meta::CPAN
is( aid_by_code( $dbix_conn, 'orneryFooBarred' ), undef, 'aid_by_code returns undef if code does not exist' );
note( 'insert an activity (success)' );
my $bogus_act = App::Dochazka::REST::Model::Activity->spawn(
code => 'boguS',
long_desc => 'An activity',
remark => 'ACTIVITY',
);
note( "About to insert bogus_act" );
$status = $bogus_act->insert( $faux_context );
if ( $status->not_ok ) {
diag( Dumper $status );
BAIL_OUT(0);
}
is( $status->level, 'OK', "Insert activity with code 'bogus'" );
ok( defined( $bogus_act->aid ) );
ok( $bogus_act->aid > 0 );
# test code accessor method and code_to_upper trigger
is( $bogus_act->code, 'BOGUS' );
is( $bogus_act->long_desc, "An activity" );
is( $bogus_act->remark, 'ACTIVITY' );
note( 'try to insert the same activity again (fail with DOCHAZKA_DBI_ERR)' );
$status = $bogus_act->insert( $faux_context );
ok( $status->not_ok );
is( $status->level, 'ERR' );
is( $status->code, 'DOCHAZKA_DBI_ERR' );
like( $status->text, qr/Key \(code\)\=\(BOGUS\) already exists/ );
note( 'get_all_activities -> now there is one more' );
$status = get_all_activities( $dbix_conn );
is( $status->level, 'OK' );
is( $status->code, 'DISPATCH_RECORDS_FOUND' );
is( scalar( @{ $status->payload } ), ( $initial_noof_act + 1 ) );
note( 'update the activity (success)' );
$bogus_act->{code} = "bogosITYVille";
$bogus_act->{long_desc} = "A bogus activity that doesn't belong here";
$bogus_act->{remark} = "BOGUS ACTIVITY";
$bogus_act->{disabled} = 1;
#diag( "About to update bogus_act" );
$status = $bogus_act->update( $faux_context );
if ( $status->not_ok ) {
diag( Dumper $status );
BAIL_OUT(0);
}
is( $status->level, 'OK' );
note( 'test accessors' );
is( $bogus_act->code, 'BOGOSITYVILLE' );
is( $bogus_act->long_desc, "A bogus activity that doesn't belong here" );
is( $bogus_act->remark, 'BOGUS ACTIVITY' );
ok( $bogus_act->disabled );
t/model/activity.t view on Meta::CPAN
$status = get_all_activities( $dbix_conn, disabled => 1 );
is( $status->level, 'OK' );
is( $status->code, 'DISPATCH_RECORDS_FOUND' );
is( $status->{'count'}, ( $initial_noof_act + 1 ) );
# - and BOGOSITYVILLE is there
ok( scalar( grep { $_->{'code'} eq 'BOGOSITYVILLE'; } @{ $status->payload } ) );
note( 'CLEANUP: delete the bogus activity' );
#diag( "About to delete bogus_act" );
$status = $bogus_act->delete( $faux_context );
if ( $status->not_ok ) {
diag( Dumper $status );
BAIL_OUT(0);
}
is( $status->level, 'OK' );
ok( ! aid_exists( $dbix_conn, $aid_of_bogus_act ) );
ok( ! code_exists( $dbix_conn, $code_of_bogus_act ) );
note( 'attempt to load the bogus activity - no longer there' );
$status = App::Dochazka::REST::Model::Activity->load_by_code( $dbix_conn, 'BOGUS' );
t/model/component.t view on Meta::CPAN
note( 'insert a component (success)' );
my $non_bogus_component = App::Dochazka::REST::Model::Component->spawn(
path => 'non/bogus',
source => 'An componnennt',
acl => 'passerby',
);
note( "About to insert non_bogus_component" );
$status = $non_bogus_component->insert( $faux_context );
if ( $status->not_ok ) {
diag( Dumper $status );
BAIL_OUT(0);
}
is( $status->level, 'OK' );
ok( defined( $non_bogus_component->cid ) );
ok( $non_bogus_component->cid > 0 );
is( $non_bogus_component->path, 'non/bogus' );
is( $non_bogus_component->source, "An componnennt" );
is( $non_bogus_component->acl, 'passerby' );
note( 'try to insert the same component again (fail with DOCHAZKA_DBI_ERR)' );
$status = $non_bogus_component->insert( $faux_context );
ok( $status->not_ok );
is( $status->level, 'ERR' );
is( $status->code, 'DOCHAZKA_DBI_ERR' );
like( $status->text, qr#Key \(path\)\=\(non/bogus\) already exists# );
note( 'update the component (success)' );
$non_bogus_component->{path} = "bogosITYVille";
$non_bogus_component->{source} = "A bogus component that doesn't belong here";
$non_bogus_component->{acl} = 'inactive';
#diag( "About to update non_bogus_component" );
$status = $non_bogus_component->update( $faux_context );
if ( $status->not_ok ) {
diag( Dumper $status );
BAIL_OUT(0);
}
is( $status->level, 'OK' );
note( 'test accessors' );
is( $non_bogus_component->path, 'bogosITYVille' );
is( $non_bogus_component->source, "A bogus component that doesn't belong here" );
is( $non_bogus_component->acl, 'inactive' );
t/model/component.t view on Meta::CPAN
my $cid_of_non_bogus_component = $non_bogus_component->cid;
my $path_of_non_bogus_component = $non_bogus_component->path;
ok( cid_exists( $dbix_conn, $cid_of_non_bogus_component ) );
ok( path_exists( $dbix_conn, $path_of_non_bogus_component ) );
note( 'CLEANUP: delete the bogus component' );
#diag( "About to delete non_bogus_component" );
$status = $non_bogus_component->delete( $faux_context );
if ( $status->not_ok ) {
diag( Dumper $status );
BAIL_OUT(0);
}
is( $status->level, 'OK' );
ok( ! cid_exists( $dbix_conn, $cid_of_non_bogus_component ) );
ok( ! path_exists( $dbix_conn, $path_of_non_bogus_component ) );
note( 'attempt to load the bogus component - no longer there' );
$status = App::Dochazka::REST::Model::Component->load_by_cid( $dbix_conn, $cid_of_non_bogus_component );
t/model/employee.t view on Meta::CPAN
ok( $status->ok, "UPDATE status is OK" );
$status = App::Dochazka::REST::Model::Employee->load_by_nick( $dbix_conn, 'mrsfu' );
is( $status->code, 'DISPATCH_RECORDS_FOUND', "Nick mrsfu exists" );
my $emp2 = $status->payload;
is_deeply( $emp, $emp2 );
note( "pathologically change Mrs. Fu's nick to null" );
my $saved_nick = $emp->nick;
$emp->{'nick'} = undef;
$status = $emp->update( $faux_context );
ok( $status->not_ok );
is( $status->level, 'ERR' );
is( $status->code, 'DOCHAZKA_DBI_ERR' );
$emp->nick( $saved_nick );
note( "attempt to change Mr. Fu's supervisor to Mr. Fu - i.e. he would supervise himself" );
$mrfu->supervisor( $eid_of_mrfu );
$status = $mrfu->update( $faux_context );
is( $status->level, 'ERR' );
is( $status->code, 'DOCHAZKA_DBI_ERR' );
t/model/interval_lock.t view on Meta::CPAN
( $by, $bm, $bd ) = $d =~ m/(\d+)-(\d+)-(\d+)/;
( $ey, $em, $ed ) = Add_Delta_Days( $by, $bm, $bd, 65 );
$end_date = sprintf( "%04d-%02d-%02d", $ey, $em, $ed );
$count = 0;
while ( $d ne $end_date ) {
foreach my $intvl ( "[ $d 08:00, $d 10:00 )", "[ $d 10:00, $d 12:00 )", "[ $d 12:30, $d 14:30 )", "[ $d 14:30, $d 16:30 )" ) {
$count += 1;
$int->iid( undef );
$int->intvl( $intvl );
$status = $int->insert( $faux_context );
if( $status->not_ok ) {
diag( "Count: $count" );
diag( Dumper $status );
BAIL_OUT(0);
}
is( $status->level, 'OK' );
is( $status->code, 'DOCHAZKA_CUD_OK' );
ok( $int->iid > 0 );
}
$d = get_tomorrow( $d );
}
t/model/privhistory.t view on Meta::CPAN
my $ins_effective = $today_ts;
my $ins_remark = 'TESTING';
my $priv = App::Dochazka::REST::Model::Privhistory->spawn(
eid => $ins_eid,
priv => $ins_priv,
effective => $ins_effective,
remark => $ins_remark,
);
is( $priv->phid, undef, "phid undefined before INSERT" );
$status = $priv->insert( $faux_context );
diag( $status->text ) if $status->not_ok;
ok( $status->ok, "Post-insert status ok" );
ok( $priv->phid > 0, "INSERT assigned an phid" );
is( $priv->remark, $ins_remark, "remark survived INSERT" );
note( 'do a dastardly deed (insert the same privhistory row a second time)');
my $dastardly_sh = App::Dochazka::REST::Model::Privhistory->spawn(
eid => $ins_eid,
priv => $ins_priv,
effective => $ins_effective,
remark => 'Dastardly',
t/model/privhistory.t view on Meta::CPAN
note( 'add another record within the range' );
my $priv3 = App::Dochazka::REST::Model::Privhistory->spawn(
eid => $ins_eid,
priv => 'passerby',
effective => "$today 02:00",
remark => $ins_remark,
);
is( $priv3->phid, undef, "phid undefined before INSERT" );
$status = $priv3->insert( $faux_context );
diag( $status->text ) if $status->not_ok;
ok( $status->ok, "Post-insert status ok" );
ok( $priv3->phid > 0, "INSERT assigned an phid" );
note( 'test get_privhistory again -- do we get two records?' );
$status = get_privhistory( $faux_context, eid => $emp->eid, tsrange => "[$today_ts, $tomorrow_ts)" );
ok( $status->ok, "Privhistory record found" );
$ph = $status->payload->{'history'};
is( scalar @$ph, 2, "Two records" );
#diag( Dumper( $ph ) );
( run in 0.942 second using v1.01-cache-2.11-cpan-0a987023a57 )