App-Dochazka-REST
view release on metacpan or search on metacpan
- Factory.pm: add new module under Util/ with 'makereset' function
- Employee.pm: use new makereset function
0.029 2014-07-08 23:46 CEST
- Privhistory.pm: use the new function 'makereset', move priv_by_eid to
Factory.pm (not sure if it really belongs here, though)
- Factory.pm: refactor makereset
0.030 2014-07-09 00:29 CEST
- Factory.pm, Employee.pm, Privhistory.pm: add and use 'make_spawn'
- t/006-reset.t: add test demonstrating how spawn "validates" the
attributes provided in PARAMHASH
- Privhistory.pm no longer exports any functions
0.031 2014-07-09 01:32 CEST
- t/005-privhistory.t: add unit tests
- Privhistory.pm: make 'load' trigger warning if nothing found
0.032 2014-07-09 12:09 CEST
- make privhistory SQL statements return int_id where appropriate
- t/005-privhistory.t: add some int_id tests
- Build.PL: build_require Test::Fatal, require Params::Validate
- Model/Activity.pm: add parameter validation code
0.126 2014-08-01 13:23 CEST
- Model/Activity.pm: load_by_code, load_by_aid, _load now use "best practices"
established in Model/Employee.pm
- start adding parameter validation code using Param::Validate
- start adding unit tests for the new parameter validation code
0.127 2014-08-01 17:07 CEST
- cleanup, validate parameters, add some tests that call functions with
invalid parameters
0.128 2014-08-01 18:21 CEST
- Model/Activity.pm, Model/Shared.pm: moved '_load' to shared so code can
be re-used
0.129 2014-08-01 18:54 CEST
- Model/Employee.pm: use the new Shared.pm->load routine
- Model/Activity.pm, Model/Employee.pm: eliminate deprecated _load routines
- t/: update tests to current state
0.160 2014-08-16 10:17 CEST
- bin/dochazka-rest: comment out 'die' statement so server runs again
0.161 2014-08-18 10:38 CEST
- fix bug: "LDAP users can log in with wrong/no password"
0.162 2014-08-21 15:31 CEST
- t/002-root.t: fix broken unit test
- bin/dochazka-rest: turn on debug_mode
- Resource.pm: uncomment session ID debug message in _validate_session
0.163 2014-08-27 17:42 CEST
- Dispatch/Employee.pm->_put_employee: allow undef as value for optional fields
('fullname', 'email', 'passhash', 'salt', 'remark')
- Model/Employee.pm->expurgate: when expurgating employee objects, do not
remove 'passhash' and 'salt' properties
0.164 2014-08-28 11:26 CEST
- Model/Shared.pm: do not put empty strings into the database
- t/dispatch/history.t: add more tests; improve comments
0.301 2014-11-23 23:24 CET
- Dispatch/ACL.pm: make 'check_acl_context' return OK status when the
request passes its check
- Dispatch/Shared.pm: block out an 'interval_sanity' routine (WIP)
- Dispatch/{Interval,Lock}.pm: adapt to current state
0.302 2014-11-24 14:43 CET
- dbinit_Config.pm: add 'no_intervals_after' and 'intvl_ok' stored PL/pgSQL procedures
- Dispatch/Interval.pm: make '_insert_interval' validate its arguments using Params::Validate
- Dispatch/Shared.pm: test attendance and lock intervals for bad string 'infinity';
add 'lock_sanity' routine to perform analogous role to 'interval_sanity'
0.303 2014-11-24 16:47 CET
- config/sql/: globally replace tsrange with tstzrange and TIMESTAMP
WITHOUT TIME ZONE to TIMESTAMP WITH TIME ZONE, etc.; add triggers to
'intervals' and 'locsk' so all new 'intvl' values are vetted at insert/update
using the 'intvl_ok' stored procedure
- Dispatch/Shared.pm: tweak '_no_infinity'
- t/: with the change to "WITH TIME ZONE", some return values have "+01"
- Model/Interval.pm: simplify interval summary data structure
- Dispatch.pm: require 'source', 'acl' properties for insert only
- t/dispatch/interval_lock.t: add interval/summary tests
- Implement feature "Component class: add validations property" (#54)
- sql/component_Config.pm: add validations to SQL statements
- sql/dbinit_Config.pm: add validations to components table
- REST.pm->reset_db: add validations to SQL_COMPONENT_INSERT
- Model/Component.pm: add validations property
- t/dispatch/component.t: add validations property
- Build.PL: require App::Dochazka::Common 0.199 for component validations
- Fix bug "genreport resource does not validate parameters" (#53)
- genreport resource: apply validations, if any
- REST/Dispatch.pm->handler_genreport(): vet parameters more carefully
0.517 2016-01-11 00:29 CET
- config/Component_Config.pm: use Data::Dumper in component
- config/Component_Config.pm: beginnings of monthly report template
- t/model/tempintvls.t: change Util::Date to Holiday
- Dispatch.pm->handler_genreport(): refactor function
- Revamp Docker testing environment:
- version.plx: Perl script to print App::Dochazka::REST version
0.545 2016-09-23 14:45 CEST
- cleanup: reduce log verbosity of load_multile() in Model/Shared.pm
- Auth.pm: add more debug log messages, session mgmt
0.546 2016-09-25 09:44 CEST
- Revamp session management
- doc: update session management section of Guide
0.547 2016-09-26 14:00 CEST
- run-tests.sh: do not make an empty "1" file
- Auth.pm: require 'eid' property in _validate_session()
- model: stricter match for system users in ldap_sync()
- dispatch: improve error messages generated by LDAP handlers
0.548 2016-11-01 15:43 CET
- build/ops: move project back to Application:Dochazka (in OBS)
- Dispatch.pm: fix session resource
- Implement new "session/terminate" resource
0.549 2017-03-02 00:57 CET
- tests: fix top-level resource sanity test
lib/App/Dochazka/REST/ACL.pm view on Meta::CPAN
employee, respectively. The function returns a true or false value indicating
whether that employee satisfies the given ACL profile.
In addition to the usual privlevels, the C<profile> property can be
'forbidden', in which case the function returns false for all possible values
of C<privlevel>.
=cut
sub check_acl {
my ( %ARGS ) = validate( @_, {
profile => { type => SCALAR, regex => qr/^(passerby)|(inactive)|(active)|(admin)|(forbidden)$/ },
privlevel => { type => SCALAR, regex => qr/^(passerby)|(inactive)|(active)|(admin)$/ },
} );
return exists( $acl_lookup{$ARGS{privlevel}}->{$ARGS{profile}} )
? 1
: 0;
}
=head2 check_acl_context
lib/App/Dochazka/REST/Auth.pm view on Meta::CPAN
=cut
sub is_authorized {
my ( $self, $auth_header ) = @_;
$log->debug( "Entering " . __PACKAGE__ . "::is_authorized" );
# get database connection for this HTTP request
App::Dochazka::REST::ConnBank::init_singleton();
if ( ! $meta->META_DOCHAZKA_UNIT_TESTING ) {
return 1 if $self->_validate_session;
}
if ( $auth_header ) {
$log->debug("is_authorized: auth header is $auth_header" );
my $username = $auth_header->username;
my $password = $auth_header->password;
my $auth_status = $self->_authenticate( $username, $password );
if ( $auth_status->ok ) {
my $emp = $auth_status->payload;
$self->push_onto_context( {
current => $emp->TO_JSON,
lib/App/Dochazka/REST/Auth.pm view on Meta::CPAN
=head3 _init_session
Initialize the session. Takes an employee object.
=cut
sub _init_session {
my $self = shift;
$log->debug( "Entering " . __PACKAGE__ . "::_init_session" );
my ( $emp ) = validate_pos( @_, { type => HASHREF, can => 'eid' } );
my $r = $self->request;
my $ip_addr = $r->{'env'}->{'REMOTE_ADDR'};
my $session = $r->{'env'}->{'psgix.session'};
my $eid = $emp->eid;
$session->{'eid'} = $eid;
$session->{'ip_addr'} = $ip_addr;
$session->{'last_seen'} = time;
$log->info( "Initialized new session, EID $eid" );
return;
}
=head3 _validate_session
Validate the session
=cut
sub _validate_session {
my ( $self ) = @_;
$log->debug( "Entering " . __PACKAGE__ . "::_validate_session" );
my $r = $self->request;
my $remote_addr = $r->{'env'}->{'REMOTE_ADDR'};
my $session = $r->{'env'}->{'psgix.session'};
$log->debug( "Session is " . Dumper( $session ) );
return 0 unless %$session;
return 0 unless _is_fresh( $session->{'last_seen'} );
lib/App/Dochazka/REST/Auth.pm view on Meta::CPAN
Takes a single argument, which is assumed to be number of seconds since
epoch when the session was last seen. This is compared to "now" and if the
difference is greater than the DOCHAZKA_REST_SESSION_EXPIRATION_TIME site
parameter, the return value is false, otherwise true.
=cut
sub _is_fresh {
$log->debug( "Entering " . __PACKAGE__ . "::_is_fresh" );
my ( $last_seen ) = validate_pos( @_, { type => SCALAR } );
if ( time - $last_seen > $site->DOCHAZKA_REST_SESSION_EXPIRATION_TIME ) {
$log->error( "Session expired!" );
return 0;
}
return 1;
}
=head3 _authenticate
lib/App/Dochazka/REST/Dispatch.pm view on Meta::CPAN
# - if there is a validations property, convert it into a hashref
# and check the parameters against it
if ( $comp->{validations} ) {
my $validations = eval $comp->{validations};
$log->debug( "Validations before eval: " . Dumper $comp->{validations} );
$log->debug( "Validations after eval: " . Dumper $validations );
die "AGAAKH! validations is not a HASHREF: $validations" unless
ref( $validations ) eq 'HASH';
$parameters = {} if not defined $parameters;
$log->debug( "About to validate parameters: " . Dumper $parameters );
my $success = 1;
validate_with(
params => $parameters,
spec => $validations,
on_fail => sub {
my $errmsg = shift;
$self->mrest_declare_status( code => 400, explanation => $errmsg );
$success = 0;
},
);
return $fail unless $success;
} elsif ( $parameters ) {
lib/App/Dochazka/REST/Docs/Resources.pm view on Meta::CPAN
The "POST genreport" resource generates reports from Mason templates.
The resource takes a request body with one mandatory property, "path"
(corresponding to the path of a Mason component relative to the component
root), and one optional property, "parameters", which should be a hash
of parameter names and values.
The resource handler checks (1) if the component exists in the database,
(2) whether current employee has sufficient permissions to generate the
report (by comparing the employee's privlevel with the ACL profile of the
component), and (3) validates the parameters, if any, by applying the
validation rules specified in the component object. Iff all of these
conditions are met, the component is called with the provided parameters.
=back
=head2 C<< holiday/:tsrange >>
=over
lib/App/Dochazka/REST/Fillup.pm view on Meta::CPAN
map {
my $fn = __PACKAGE__ . "::$_";
$log->debug( "BEGIN BLOCK: $_ $fn" );
*{ $fn } =
App::Dochazka::Common::Model::make_accessor( $_, $attr{ $_ } );
} keys %attr;
*{ 'reset' } = sub {
# process arguments
my $self = shift;
my %ARGS = validate( @_, \%attr ) if @_ and defined $_[0];
# Wipe out current TIID
$self->DESTROY;
# Set attributes to run-time values sent in argument list.
# Attributes that are not in the argument list will get set to undef.
map { $self->{$_} = $ARGS{$_}; } keys %attr;
# run the populate function, if any
$self->populate() if $self->can( 'populate' );
lib/App/Dochazka/REST/Fillup.pm view on Meta::CPAN
This is used to make sure the employee's schedule and priv level did not
change during the time period represented by the date list, as well as in
C<fillup_tempintvls> to generate the C<tempintvl> working set.
Returns a status object.
=cut
sub _vet_date_list {
my $self = shift;
my ( %ARGS ) = validate( @_, {
date_list => { type => ARRAYREF|UNDEF },
} );
$log->debug( "Entering " . __PACKAGE__ . "::_vet_date_list to vet/populate the date_list property" );
if ( $ARGS{'date_list'} ) {
$log->debug( "Date list is " . Dumper $ARGS{'date_list'} );
}
die "GOPHFQQ! tsrange property must not be populated in _vet_date_list()" if $self->tsrange;
return $CELL->status_ok if not defined( $ARGS{date_list} );
lib/App/Dochazka/REST/Fillup.pm view on Meta::CPAN
Takes an employee object. First, retrieves
from the database the employee object corresponding to the EID. Second,
checks that the employee's privlevel did not change during the tsrange.
Third, retrieves the prevailing schedule and checks that the schedule does
not change at all during the tsrange. Returns a status object.
=cut
sub _vet_employee {
my $self = shift;
my ( %ARGS ) = validate( @_, {
emp_obj => {
type => HASHREF,
isa => 'App::Dochazka::REST::Model::Employee',
},
} );
my $status;
die 'AKLDWW###%AAAAAH!' unless $ARGS{emp_obj}->eid;
$self->{'emp_obj'} = $ARGS{emp_obj};
lib/App/Dochazka/REST/Fillup.pm view on Meta::CPAN
=head2 _vet_activity
Takes a C<DBIx::Connector> object and an AID. Verifies that the AID exists
and populates the C<activity_obj> attribute.
=cut
sub _vet_activity {
my $self = shift;
my ( %ARGS ) = validate( @_, {
aid => { type => SCALAR|UNDEF, optional => 1 },
} );
my $status;
if ( exists( $ARGS{aid} ) and defined( $ARGS{aid} ) ) {
# load activity object from database into $self->{act_obj}
$status = App::Dochazka::REST::Model::Activity->load_by_aid(
$self->context->{'dbix_conn'},
$ARGS{aid}
);
lib/App/Dochazka/REST/Fillup.pm view on Meta::CPAN
Constructor method. Returns an C<App::Dochazka::REST::Fillup>
object.
The constructor method does everything up to C<fillup>. It also populates the
C<constructor_status> attribute with an C<App::CELL::Status> object.
=cut
sub new {
my $class = shift;
my ( %ARGS ) = validate( @_, {
context => { type => HASHREF },
emp_obj => {
type => HASHREF,
isa => 'App::Dochazka::REST::Model::Employee',
},
aid => { type => SCALAR|UNDEF, optional => 1 },
code => { type => SCALAR|UNDEF, optional => 1 },
tsrange => { type => SCALAR, optional => 1 },
date_list => { type => ARRAYREF, optional => 1 },
long_desc => { type => SCALAR|UNDEF, optional => 1 },
lib/App/Dochazka/REST/Guide.pm view on Meta::CPAN
One of the first things the server looks at, when it receives a request, is
the method. Only certain HTTP methods, such as 'GET' and 'POST', are accepted.
If this test fails, a "405 Method Not Allowed" response is sent.
=item * B<Internal and external authentication, session management>
This takes place when L<Web::Machine> calls the C<is_authorized> method,
our implementation of which is in L<App::Dochazka::REST::Auth>.
Though the method is called C<is_authorized>, what it really does is
authenticate the request - i.e., validate the user's credentials to
determine his or her identity. B<Authorization> - determination whether the
user has sufficient privileges to make the request - takes place one step
further on. (The HTTP standard uses the term "authorized" to mean
"authenticated"; the name of this method is a nod to that usage.)
In C<is_authorized>, the user's credentials are authenticated
against an external database (LDAP), an internal database (PostgreSQL
'employees' table), or both. Session management techniques are utilized
to minimize external authentication queries, which impose latency. The
authentication and session management algorithms are described in
lib/App/Dochazka/REST/Guide.pm view on Meta::CPAN
=head1 AUTHENTICATION AND SESSION MANAGEMENT
Employees do not access the database directly, but only via HTTP requests.
For authorization and auditing purposes, L<App::Dochazka::REST> needs to
associate each incoming request to an EID.
The L<Plack::Middleware::Session> module associates each incoming request with
a session. Sessions are validated by examining the session state in the
L<App::Dochazka::REST::Auth> module.
=head2 Existing session
If the session state is valid, it will contain:
=over
=item * the Employee ID, C<eid>
lib/App/Dochazka/REST/Holiday.pm view on Meta::CPAN
my $holidays1 = holidays_in_daterange(
begin => '2001-01-02',
end => '2001-12-24',
);
my $holidays2 = holidays_in_daterange(
begin => '2001-01-02',
end => '2002-12-24',
);
*WARNING*: C<holidays_in_daterange()> makes no attempt to validate the date
range. It assumes this validation has already taken place, and that the dates
are in YYYY-MM-DD format!
=head1 EXPORTS
=cut
lib/App/Dochazka/REST/Holiday.pm view on Meta::CPAN
'2015-01-01' => '',
'2015-05-01' => '',
}
The idea is that this hash can be used to quickly look up if a given date is a
holiday.
=cut
sub holidays_in_daterange {
my ( %ARGS ) = validate( @_, {
begin => { type => SCALAR },
end => { type => SCALAR },
} );
my $begin_year = _extract_year( $ARGS{begin} );
my $end_year = _extract_year( $ARGS{end} );
# transform daterange into an array of hashes containing "begin", "end"
# in other words:
# INPUT: { begin => '1901-06-30', end => '1903-03-15' }
lib/App/Dochazka/REST/Holiday.pm view on Meta::CPAN
'2015-01-05' => {},
'2015-01-06' => {},
}
Note that the range is always considered inclusive -- i.e. the bounding
dates of the range will be included in the hash.
=cut
sub holidays_and_weekends {
my ( %ARGS ) = validate( @_, {
begin => { type => SCALAR },
end => { type => SCALAR },
} );
my $holidays = holidays_in_daterange( %ARGS );
my $res = {};
my $d = $ARGS{begin};
$log->debug( "holidays_and_weekends \$d == $d" );
while ( $d ne get_tomorrow( $ARGS{end} ) ) {
$res->{ $d } = {};
if ( is_weekend( $d ) ) {
lib/App/Dochazka/REST/Holiday.pm view on Meta::CPAN
die "AUCKLANDERS! ymd out of range!!";
}
return sprintf( "%04d-%02d-%02d", $y, $m, $d );
}
# HELPER FUNCTIONS
sub _daterange_by_year {
my ( %ARGS ) = validate( @_, {
begin_year => { type => SCALAR },
end_year => { type => SCALAR },
begin_date => { type => SCALAR },
end_date => { type => SCALAR },
} );
my $year_delta = $ARGS{end_year} - $ARGS{begin_year};
if ( $year_delta == 0 ) {
return { $ARGS{begin_year} => { begin => $ARGS{begin}, end => $ARGS{end} } };
}
if ( $year_delta == 1 ) {
lib/App/Dochazka/REST/LDAP.pm view on Meta::CPAN
Takes a nick. Returns true or false. Determines if the nick exists in the LDAP database.
Any errors in communication with the LDAP server are written to the log.
=cut
# $ldap and $dn are used by both 'ldap_exists' and 'ldap_search'
my ( $ldap, $dn );
sub ldap_exists {
my ( $nick ) = validate_pos( @_, { type => SCALAR } );
return 0 unless $site->DOCHAZKA_LDAP;
require Net::LDAP;
my $server = $site->DOCHAZKA_LDAP_SERVER;
$ldap = Net::LDAP->new( $server );
$log->error("$@") unless $ldap;
return 0 unless $ldap;
lib/App/Dochazka/REST/Mason.pm view on Meta::CPAN
FIXME: Add parameters to the Mason->new() call as needed.
=cut
sub init_singleton {
my @ARGS = @_;
my %ARGS;
my $status = $CELL->status_ok;
try {
%ARGS = validate(
@ARGS, {
comp_root => { type => SCALAR },
data_dir => { type => SCALAR },
}
);
die "Mason comp_root $ARGS{comp_root} has a problem" unless
(
-r $ARGS{comp_root} and
-w $ARGS{comp_root} and
-x $ARGS{comp_root}
lib/App/Dochazka/REST/Model/Activity.pm view on Meta::CPAN
=head2 insert
Instance method. Takes the object, as it is, and attempts to insert it into
the database. On success, overwrites object attributes with field values
actually inserted. Returns a status object.
=cut
sub insert {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
my $status = cud(
conn => $context->{'dbix_conn'},
eid => $context->{'current'}->{'eid'},
object => $self,
sql => $site->SQL_ACTIVITY_INSERT,
attrs => [ 'code', 'long_desc', 'remark' ],
);
return $status;
lib/App/Dochazka/REST/Model/Activity.pm view on Meta::CPAN
corresponds to the activity to be updated and the attributes have been
changed as desired, this function runs the actual UPDATE, hopefully
bringing the database into line with the object. Overwrites all the
object's attributes with the values actually written to the database.
Returns status object.
=cut
sub update {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
return $CELL->status_err( 'DOCHAZKA_MALFORMED_400' ) unless $self->{'aid'};
my $status = cud(
conn => $context->{'dbix_conn'},
eid => $context->{'current'}->{'eid'},
object => $self,
sql => $site->SQL_ACTIVITY_UPDATE,
attrs => [ 'code', 'long_desc', 'remark', 'disabled', 'aid' ],
);
lib/App/Dochazka/REST/Model/Activity.pm view on Meta::CPAN
Instance method. Assuming the AID really corresponds to the activity to be
deleted, this method will execute the DELETE statement in the database. It
won't succeed if the activity has any intervals associated with it. Returns
a status object.
=cut
sub delete {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
my $status = cud(
conn => $context->{'dbix_conn'},
eid => $context->{'current'}->{'eid'},
object => $self,
sql => $site->SQL_ACTIVITY_DELETE,
attrs => [ 'aid' ],
);
$self->reset( aid => $self->{aid} ) if $status->ok;
lib/App/Dochazka/REST/Model/Activity.pm view on Meta::CPAN
into a newly-spawned object. The code must be an exact match. Returns a
status object: if the object is loaded, the code will be
'DISPATCH_RECORDS_FOUND' and the object will be in the payload; if
the AID is not found in the database, the code will be
'DISPATCH_NO_RECORDS_FOUND'. A non-OK status indicates a DBI error.
=cut
sub load_by_aid {
my $self = shift;
my ( $conn, $aid ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
);
return load(
conn => $conn,
class => __PACKAGE__,
sql => $site->SQL_ACTIVITY_SELECT_BY_AID,
keys => [ $aid ],
);
lib/App/Dochazka/REST/Model/Activity.pm view on Meta::CPAN
=head2 load_by_code
Analogous method to L<"load_by_aid">.
=cut
sub load_by_code {
my $self = shift;
my ( $conn, $code ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
);
return load(
conn => $conn,
class => __PACKAGE__,
sql => $site->SQL_ACTIVITY_SELECT_BY_CODE,
keys => [ $code ],
);
lib/App/Dochazka/REST/Model/Activity.pm view on Meta::CPAN
=head2 aid_by_code
Given a code, attempt to retrieve the corresponding AID.
Returns AID or undef on failure.
=cut
sub aid_by_code {
my ( $conn, $code ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
);
my $status = __PACKAGE__->load_by_code( $conn, $code );
return $status->payload->{'aid'} if $status->code eq 'DISPATCH_RECORDS_FOUND';
return;
}
=head2 code_by_aid
Given an AID, attempt to retrieve the corresponding code.
Returns code or undef on failure.
=cut
sub code_by_aid {
my ( $conn, $aid ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
);
my $status = __PACKAGE__->load_by_aid( $conn, $aid );
return $status->payload->{'code'} if $status->code eq 'DISPATCH_RECORDS_FOUND';
return;
}
lib/App/Dochazka/REST/Model/Activity.pm view on Meta::CPAN
either true or false (defaults to false).
Returns a reference to a hash of hashes, where each hash is one activity object.
If 'disabled' is true, all activities including disabled ones will be included,
otherwise only the non-disabled activities will be retrieved.
=cut
sub get_all_activities {
my $conn = shift;
my %PH = validate( @_, {
disabled => { type => SCALAR, default => 0 }
} );
my $sql = $PH{disabled}
? $site->SQL_ACTIVITY_SELECT_ALL_INCLUDING_DISABLED
: $site->SQL_ACTIVITY_SELECT_ALL_EXCEPT_DISABLED;
return load_multiple(
conn => $conn,
class => __PACKAGE__,
lib/App/Dochazka/REST/Model/Component.pm view on Meta::CPAN
=head2 insert
Instance method. Takes the object, as it is, and attempts to insert it into
the database. On success, overwrites object attributes with field values
actually inserted. Returns a status object.
=cut
sub insert {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
return $CELL->status_err( 'DOCHAZKA_MALFORMED_400' ) unless
(
$self->{'path'} and $self->{'source'} and $self->{'acl'} and
scalar(
grep { $self->{'acl'} eq $_ } ( 'admin', 'active', 'inactive', 'passerby' )
)
);
my $status = cud(
lib/App/Dochazka/REST/Model/Component.pm view on Meta::CPAN
corresponds to the component to be updated and the attributes have been
changed as desired, this function runs the actual UPDATE, hopefully
bringing the database into line with the object. Overwrites all the
object's attributes with the values actually written to the database.
Returns status object.
=cut
sub update {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
return $CELL->status_err( 'DOCHAZKA_MALFORMED_400' ) unless
(
$self->{'cid'} and
(
$self->{'path'} or $self->{'source'} or $self->{'acl'}
)
);
return $CELL->status_err( 'DOCHAZKA_MALFORMED_400' ) if
lib/App/Dochazka/REST/Model/Component.pm view on Meta::CPAN
Instance method. Assuming the CID really corresponds to the component to be
deleted, this method will execute the DELETE statement in the database. No
attempt is made to protect from possible deleterious consequences of
deleting components. Returns a status object.
=cut
sub delete {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
my $status = cud(
conn => $context->{'dbix_conn'},
eid => $context->{'current'}->{'eid'},
object => $self,
sql => $site->SQL_COMPONENT_DELETE,
attrs => [ 'cid' ],
);
if ( $status->ok ) {
$self->delete_file;
lib/App/Dochazka/REST/Model/Component.pm view on Meta::CPAN
into a newly-spawned object. The CID must be an exact match. Returns a
status object: if the object is loaded, the status code will be
'DISPATCH_RECORDS_FOUND' and the object will be in the payload; if
the CID is not found in the database, the status code will be
'DISPATCH_NO_RECORDS_FOUND'. A non-OK status indicates a DBI error.
=cut
sub load_by_cid {
my $self = shift;
my ( $conn, $cid ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
);
return load(
conn => $conn,
class => __PACKAGE__,
sql => $site->SQL_COMPONENT_SELECT_BY_CID,
keys => [ $cid ],
);
lib/App/Dochazka/REST/Model/Component.pm view on Meta::CPAN
=head2 load_by_path
Analogous method to L<"load_by_cid">.
=cut
sub load_by_path {
my $self = shift;
my ( $conn, $path ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
);
$path =~ s{^/}{};
return load(
conn => $conn,
class => __PACKAGE__,
sql => $site->SQL_COMPONENT_SELECT_BY_PATH,
lib/App/Dochazka/REST/Model/Component.pm view on Meta::CPAN
=head2 cid_by_path
Given a path, attempt to retrieve the corresponding CID.
Returns CID or undef on failure.
=cut
sub cid_by_path {
my ( $conn, $path ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
);
my $status = __PACKAGE__->load_by_path( $conn, $path );
return $status->payload->{'cid'} if $status->code eq 'DISPATCH_RECORDS_FOUND';
return;
}
lib/App/Dochazka/REST/Model/Employee.pm view on Meta::CPAN
=head2 priv
Accessor method. Wrapper for App::Dochazka::REST::Model::Shared::priv_by_eid
N.B.: for this method to work, the 'eid' attribute must be populated
=cut
sub priv {
my $self = shift;
my ( $conn, $timestamp ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR, optional => 1 },
);
my $return_value = ( $timestamp )
? priv_by_eid( $conn, $self->eid, $timestamp )
: priv_by_eid( $conn, $self->eid );
return if ref( $return_value );
return $return_value;
}
=head2 schedule
Accessor method. Wrapper for App::Dochazka::REST::Model::Shared::schedule_by_eid
N.B.: for this method to work, the 'eid' attribute must be populated
=cut
sub schedule {
my $self = shift;
my ( $conn, $timestamp ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR, optional => 1 },
);
my $return_value = ( $timestamp )
? schedule_by_eid( $conn, $self->eid, $timestamp )
: schedule_by_eid( $conn, $self->eid );
return if ref( $return_value );
return $return_value;
}
lib/App/Dochazka/REST/Model/Employee.pm view on Meta::CPAN
=head2 insert
Instance method. Takes the object, as it is, and attempts to insert it into
the database. On success, overwrites object attributes with field values
actually inserted. Returns a status object.
=cut
sub insert {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
$self->{sync} = 0 unless defined( $self->{sync} );
my $status = cud(
conn => $context->{'dbix_conn'},
eid => $context->{'current'}->{'eid'},
object => $self,
sql => $site->SQL_EMPLOYEE_INSERT,
attrs => [ 'sec_id', 'nick', 'fullname', 'email', 'passhash', 'salt',
'sync', 'supervisor', 'remark' ],
lib/App/Dochazka/REST/Model/Employee.pm view on Meta::CPAN
corresponds to the employee to be updated and the attributes have been
changed as desired, this function runs the actual UPDATE, hopefully
bringing the database into line with the object. Overwrites all the
object's attributes with the values actually written to the database.
Returns status object.
=cut
sub update {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
return $CELL->status_err( 'DOCHAZKA_MALFORMED_400' ) unless $self->{'eid'};
$self->{sync} = 0 unless defined( $self->{sync} );
my $status = cud(
conn => $context->{'dbix_conn'},
eid => $context->{'current'}->{'eid'},
object => $self,
sql => $site->SQL_EMPLOYEE_UPDATE_BY_EID,
lib/App/Dochazka/REST/Model/Employee.pm view on Meta::CPAN
Instance method. Assuming the EID really corresponds to the employee to be
deleted, this method will execute the DELETE statement in the database. It
won't succeed if there are any records anywhere in the database that point
to this EID. Returns a status object.
=cut
sub delete {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
my $status = cud(
conn => $context->{'dbix_conn'},
eid => $context->{'current'}->{'eid'},
object => $self,
sql => $site->SQL_EMPLOYEE_DELETE,
attrs => [ 'eid' ],
);
#$self->reset( eid => $self->eid ) if $status->ok;
return $status;
lib/App/Dochazka/REST/Model/Employee.pm view on Meta::CPAN
=head2 load_by_eid
Analogous method to L<App::Dochazka::REST::Model::Activity/"load_by_aid">.
=cut
sub load_by_eid {
my $self = shift;
my ( $conn, $eid ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
# { type => SCALAR, regex => qr/^-?\d+$/ }, <-- causes a regression
);
$log->debug( "Entering " . __PACKAGE__ . "::load_by_eid with argument $eid" );
return load(
conn => $conn,
class => __PACKAGE__,
sql => $site->SQL_EMPLOYEE_SELECT_BY_EID,
lib/App/Dochazka/REST/Model/Employee.pm view on Meta::CPAN
=head2 load_by_nick
Analogous method to L<App::Dochazka::REST::Model::Activity/"load_by_aid">.
=cut
sub load_by_nick {
my $self = shift;
my ( $conn, $nick ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
);
$log->debug( "Entering " . __PACKAGE__ . "::load_by_nick with argument $nick" );
return load(
conn => $conn,
class => __PACKAGE__,
sql => $site->SQL_EMPLOYEE_SELECT_BY_NICK,
keys => [ $nick ],
lib/App/Dochazka/REST/Model/Employee.pm view on Meta::CPAN
=head2 load_by_sec_id
Analogous method to L<App::Dochazka::REST::Model::Activity/"load_by_aid">.
FIXME: add unit tests
=cut
sub load_by_sec_id {
my $self = shift;
my ( $conn, $sec_id ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
);
$log->debug( "Entering " . __PACKAGE__ . "::load_by_sec_id with argument $sec_id" );
return load(
conn => $conn,
class => __PACKAGE__,
sql => $site->SQL_EMPLOYEE_SELECT_BY_SEC_ID,
keys => [ $sec_id ],
lib/App/Dochazka/REST/Model/Employee.pm view on Meta::CPAN
=head2 priv_change_during_range
Given a DBIx::Connector object and a tsrange, returns a non-negative integer
value signifying the number of times the employee's priv level changed during the
given range.
=cut
sub priv_change_during_range {
my $self = shift;
my ( $conn, $tsr ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
);
$log->debug( "Entering " . __PACKAGE__ . "::priv_change_during_range with argument $tsr" );
$log->debug( "EID is " . $self->eid );
my $status = select_single(
conn => $conn,
sql => $site->SQL_EMPLOYEE_PRIV_CHANGE_DURING_RANGE,
keys => [ $self->eid, $tsr ],
lib/App/Dochazka/REST/Model/Employee.pm view on Meta::CPAN
}
sub _privsched_change_during_range_result {
my ( $sql_stmt, $status ) = @_;
$log->debug( "Entering " . __PACKAGE__ . "::_privsched_change_during_range_result with status " .
Dumper $status );
# there should always be a single record, and it should be either 0 or 1
if ( ref( $status->payload ) ne 'ARRAY' ) {
die "Unexpected _privsched_change_during_range_result: status payload is not an array!";
}
my ( $plval ) = validate_pos( @{ $status->payload },
{
type => SCALAR,
callbacks => {
'non-negative integer' => sub { $_[0] >= 0 }
}
},
);
return $plval;
}
lib/App/Dochazka/REST/Model/Employee.pm view on Meta::CPAN
NOTE: be careful that the argument really is a valid timestamp or tsrange. If
it isn't valid, the DBD::Pg error will be logged and the return value will be
undef (not a L<App::Dochazka::REST::Model::Schedhistory> object whose
properties are set to undef).
=cut
sub privhistory_at_timestamp {
my $self = shift;
my ( $conn, $arg ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
);
$log->debug( "Entering " . __PACKAGE__ . "::privhistory_at_timestamp with argument $arg" );
$log->debug( "EID is " . $self->eid );
# if it looks like a tsrange, use tsrange, otherwise use timestamp
my $sql = ( $arg =~ m/[[(].*,.*[])]/ )
? $site->SQL_EMPLOYEE_PRIVHISTORY_AT_TSRANGE
: $site->SQL_EMPLOYEE_PRIVHISTORY_AT_TIMESTAMP;
lib/App/Dochazka/REST/Model/Employee.pm view on Meta::CPAN
=head2 schedule_change_during_range
Given a DBIx::Connector object and a tsrange, returns a non-negative integer
value signifying the number of times the employee's schedule changed during the
given range.
=cut
sub schedule_change_during_range {
my $self = shift;
my ( $conn, $tsr ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
);
$log->debug( "Entering " . __PACKAGE__ . "::schedule_change_during_range with argument $tsr" );
$log->debug( "EID is " . $self->eid );
my $status = select_single(
conn => $conn,
sql => $site->SQL_EMPLOYEE_SCHEDULE_CHANGE_DURING_RANGE,
keys => [ $self->eid, $tsr ],
lib/App/Dochazka/REST/Model/Employee.pm view on Meta::CPAN
NOTE: be careful that the argument really is a valid timestamp or tsrange. If
it isn't valid, the DBD::Pg error will be logged and the return value will be
undef (not a L<App::Dochazka::REST::Model::Schedhistory> object whose
properties are set to undef).
=cut
sub schedhistory_at_timestamp {
my $self = shift;
my ( $conn, $arg ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
);
$log->debug( "Entering " . __PACKAGE__ . "::schedhistory_at_timestamp with argument $arg" );
$log->debug( "EID is " . $self->eid );
# if it looks like a tsrange, use tsrange, otherwise use timestamp
my $sql = ( $arg =~ m/[[(].*,.*[])]/ )
? $site->SQL_EMPLOYEE_SCHEDHISTORY_AT_TSRANGE
: $site->SQL_EMPLOYEE_SCHEDHISTORY_AT_TIMESTAMP;
lib/App/Dochazka/REST/Model/Employee.pm view on Meta::CPAN
=head2 team_nicks
Given a L<DBIx::Connector> object, return a status object that, if successful,
will contain in the payload a list of employees whose supervisor is the
employee corresponding to C<$self>.
=cut
sub team_nicks {
my $self = shift;
my ( $conn ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
);
$log->debug( "Entering " . __PACKAGE__ . "::team_nicks for employee " . ( $self->nick || 'undefined' ) );
# no EID, no team
return $CELL->status_ok( 'TEAM', payload => [] ) unless $self->eid;
# if nick not populated, get it
$self->load_by_eid( $conn, $self->eid ) unless $self->nick =~ /\S+/;
lib/App/Dochazka/REST/Model/Employee.pm view on Meta::CPAN
Given a L<DBIx::Connector> object, return a status object that, if successful,
will contain in the payload an integer indicating how many "reports" the
employee has - i.e. how many employees, if any, there are whose supervisor is
the employee corresponding to C<$self>.
=cut
sub has_reports {
my $self = shift;
my ( $conn ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
);
$log->debug( "Entering " . __PACKAGE__ . "::has_reports for employee " . ( $self->nick || 'undefined' ) );
my $reports;
# no EID, no team
return $CELL->status_ok( 'TEAM', payload => [] ) unless $self->eid;
my $status = select_single(
'conn' => $conn,
lib/App/Dochazka/REST/Model/Employee.pm view on Meta::CPAN
=head2 list_employees_by_priv
Get employee nicks. Argument can be one of the following:
all admin active inactive passerby
=cut
sub list_employees_by_priv {
my ( $conn, $priv ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR, regex => qr/^(all)|(admin)|(active)|(inactive)|(passerby)$/ },
);
$log->debug( "Entering " . __PACKAGE__ . "::list_employees_by_priv with priv $priv" );
my $nicks = []; # reference to array of nicks
my $sql = ''; # SQL statement
my $keys_arrayref = []; # reference to array of keys (may be empty)
if ( $priv eq 'all' ) {
$sql = $site->SQL_EMPLOYEE_SELECT_NICKS_ALL
lib/App/Dochazka/REST/Model/Employee.pm view on Meta::CPAN
=head2 noof_employees_by_priv
Get number of employees. Argument can be one of the following:
total admin active inactive passerby
=cut
sub noof_employees_by_priv {
my ( $conn, $priv ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR, regex => qr/^(total)|(admin)|(active)|(inactive)|(passerby)$/ },
);
$log->debug( "Entering " . __PACKAGE__ . "::noof_employees_by_priv with priv $priv" );
$priv = lc $priv;
if ( $priv eq 'total' ) {
my $count = noof( $conn, 'employees' );
return $CELL->status_ok(
lib/App/Dochazka/REST/Model/Employee.pm view on Meta::CPAN
=head2 get_all_sync_employees
Function returns a status object. If the status is OK, the payload will contain
a reference to an array of employee objects whose sync property is true.
=cut
sub get_all_sync_employees {
my ( $conn ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
);
return load_multiple(
conn => $conn,
class => 'App::Dochazka::REST::Model::Employee',
sql => $site->SQL_EMPLOYEE_SELECT_MULTIPLE_BY_SYNC,
keys => [ 1 ],
);
}
lib/App/Dochazka/REST/Model/Interval.pm view on Meta::CPAN
=head2 load_by_iid
Boilerplate.
=cut
sub load_by_iid {
my $self = shift;
my ( $conn, $iid ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
);
return load(
conn => $conn,
class => __PACKAGE__,
sql => $site->SQL_INTERVAL_SELECT_BY_IID,
keys => [ $iid ],
);
lib/App/Dochazka/REST/Model/Interval.pm view on Meta::CPAN
=head2 insert
Instance method. Attempts to INSERT a record.
Field values are taken from the object. Returns a status object.
=cut
sub insert {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
return $CELL->status_err(
"DOCHAZKA_PARTIAL_INTERVAL_ILLEGAL_OPERATION"
) if $self->partial;
my $status = cud(
conn => $context->{'dbix_conn'},
eid => $context->{'current'}->{'eid'},
object => $self,
sql => $site->SQL_INTERVAL_INSERT,
lib/App/Dochazka/REST/Model/Interval.pm view on Meta::CPAN
=head2 update
Instance method. Attempts to UPDATE a record.
Field values are taken from the object. Returns a status object.
=cut
sub update {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
return $CELL->status_err( 'DOCHAZKA_MALFORMED_400' ) unless $self->{'iid'};
return $CELL->status_err(
"DOCHAZKA_PARTIAL_INTERVAL_ILLEGAL_OPERATION"
) if $self->partial;
my $status = cud(
conn => $context->{'dbix_conn'},
eid => $context->{'current'}->{'eid'},
lib/App/Dochazka/REST/Model/Interval.pm view on Meta::CPAN
=head2 delete
Instance method. Attempts to DELETE a record.
Field values are taken from the object. Returns a status object.
=cut
sub delete {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
return $CELL->status_err(
"DOCHAZKA_PARTIAL_INTERVAL_ILLEGAL_OPERATION"
) if $self->partial;
my $status = cud(
conn => $context->{'dbix_conn'},
eid => $context->{'current'}->{'eid'},
object => $self,
sql => $site->SQL_INTERVAL_DELETE,
lib/App/Dochazka/REST/Model/Interval.pm view on Meta::CPAN
employee's intervals that overlap (have at least one point in common with)
that tsrange.
Returns a status object. If status level is OK, the payload contains at
least one interval. If the status level is NOTICE, it means the operation
completed successfully and no overlapping intervals were found.
=cut
sub fetch_intervals_by_eid_and_tsrange_inclusive {
my ( $conn, $eid, $tsrange ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
{ type => SCALAR },
);
my $status = canonicalize_tsrange( $conn, $tsrange );
return $status unless $status->ok;
$tsrange = $status->payload;
$status = App::Dochazka::REST::Model::Employee->load_by_eid( $conn, $eid );
lib/App/Dochazka/REST/Model/Interval.pm view on Meta::CPAN
marked as such (using the C<partial> property).
Before any records are returned, the tsrange is checked to see if it
overlaps with any privlevel or schedule changes - in which case an error is
returned. This is so interval report-generators do not have to handle
changes in employee status.
=cut
sub fetch_intervals_by_eid_and_tsrange {
my ( $conn, $eid, $tsrange ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
{ type => SCALAR, optional => 1 },
);
my $status = canonicalize_tsrange( $conn, $tsrange );
return $status unless $status->ok;
$tsrange = $status->payload;
$status = App::Dochazka::REST::Model::Employee->load_by_eid( $conn, $eid );
lib/App/Dochazka/REST/Model/Interval.pm view on Meta::CPAN
=head2 delete_intervals_by_eid_and_tsrange
Given an EID and a tsrange, delete all that employee's intervals that
fall within that tsrange.
Returns a status object.
=cut
sub delete_intervals_by_eid_and_tsrange {
my ( $conn, $eid, $tsrange ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
{ type => SCALAR },
);
my $status = canonicalize_tsrange( $conn, $tsrange );
return $status unless $status->ok;
$tsrange = $status->payload;
# check for locks
lib/App/Dochazka/REST/Model/Interval.pm view on Meta::CPAN
hash keyed on activity codes. For each activity code the value is the
total number of hours spent by the employee doing that activity on the day
in question.
The interval must start and end on a day boundary (i.e. 00:00 or 24:00)
and partial intervals are treated the same as whole intervals.
=cut
sub generate_interval_summary {
my ( $conn, $eid, $tsrange ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
{ type => SCALAR },
);
my $status = canonicalize_tsrange( $conn, $tsrange );
return $status unless $status->ok;
my $canon_tsrange = $status->payload;
$log->debug( "generate_interval_summary: $canon_tsrange" );
lib/App/Dochazka/REST/Model/Lock.pm view on Meta::CPAN
=head2 load_by_lid
Instance method. Given an LID, loads a single lock into the object, rewriting
whatever was there before. Returns a status object.
=cut
sub load_by_lid {
my $self = shift;
my ( $conn, $lid ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
);
return load(
conn => $conn,
class => __PACKAGE__,
sql => $site->SQL_LOCK_SELECT_BY_LID,
keys => [ $lid ],
);
lib/App/Dochazka/REST/Model/Lock.pm view on Meta::CPAN
=head2 insert
Instance method. Attempts to INSERT a record. Field values are taken from the
object. Returns a status object.
=cut
sub insert {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
my $status = cud(
conn => $context->{'dbix_conn'},
eid => $context->{'current'}->{'eid'},
object => $self,
sql => $site->SQL_LOCK_INSERT,
attrs => [ 'eid', 'intvl', 'remark' ],
);
return $status;
lib/App/Dochazka/REST/Model/Lock.pm view on Meta::CPAN
=head2 update
Instance method. Attempts to UPDATE a record. Field values are taken from the
object. Returns a status object.
=cut
sub update {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
return $CELL->status_err( 'DOCHAZKA_MALFORMED_400' ) unless $self->{'lid'};
my $status = cud(
conn => $context->{'dbix_conn'},
eid => $context->{'current'}->{'eid'},
object => $self,
sql => $site->SQL_LOCK_UPDATE,
attrs => [ 'eid', 'intvl', 'remark', 'lid' ],
);
lib/App/Dochazka/REST/Model/Lock.pm view on Meta::CPAN
=head2 delete
Instance method. Attempts to DELETE a record. Field values are taken from the
object. Returns a status object.
=cut
sub delete {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
my $status = cud(
conn => $context->{'dbix_conn'},
eid => $context->{'current'}->{'eid'},
object => $self,
sql => $site->SQL_LOCK_DELETE,
attrs => [ 'lid' ],
);
$self->reset( lid => $self->{lid} ) if $status->ok;
lib/App/Dochazka/REST/Model/Lock.pm view on Meta::CPAN
=head2 fetch_locks_by_eid_and_tsrange
Given a L<DBIx::Connector> object, an EID, and a tsrange, returns a status
object. Upon successfully finding one or more locks, the payload will
be an ARRAYREF of lock records.
=cut
sub fetch_locks_by_eid_and_tsrange {
my ( $conn, $eid, $tsrange ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
{ type => SCALAR, optional => 1 },
);
return load_multiple(
conn => $conn,
class => __PACKAGE__,
sql => $site->SQL_LOCK_SELECT_BY_EID_AND_TSRANGE,
keys => [ $eid, $tsrange ],
lib/App/Dochazka/REST/Model/Lock.pm view on Meta::CPAN
=head2 count_locks_in_tsrange
Given a L<DBIx::Connector> object, an EID, and a tsrange, returns a status
object. If the level is OK, the payload can be expected to contain an integer
representing the number of locks that overlap (contain points in common) with
this tsrange.
=cut
sub count_locks_in_tsrange {
my ( $conn, $eid, $tsrange ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
{ type => SCALAR, optional => 1 },
);
my $status = fetch_locks_by_eid_and_tsrange( $conn, $eid, $tsrange );
if ( $status->ok ) {
my $count = @{ $status->payload };
return $CELL->status_ok( "DOCHAZKA_NUMBER_OF_LOCKS", payload => $count );
}
lib/App/Dochazka/REST/Model/Privhistory.pm view on Meta::CPAN
=head2 load_by_eid
Supposed to be a class method, but in reality we just don't care what the first
argument is.
=cut
sub load_by_eid {
shift; # discard the first argument
my ( $conn, $eid, $ts ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR }, # EID
{ type => SCALAR|UNDEF, optional => 1 }, # timestamp
);
if ( $ts ) {
return load(
conn => $conn,
class => __PACKAGE__,
sql => $site->SQL_PRIVHISTORY_SELECT_ARBITRARY,
lib/App/Dochazka/REST/Model/Privhistory.pm view on Meta::CPAN
=head2 load_by_id
Class method.
=cut
sub load_by_id {
my $self = shift;
my ( $conn, $phid ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
);
return load(
conn => $conn,
class => __PACKAGE__,
sql => $site->SQL_PRIVHISTORY_SELECT_BY_PHID,
keys => [ $phid ],
);
lib/App/Dochazka/REST/Model/Privhistory.pm view on Meta::CPAN
=head2 load_by_phid
Wrapper for load_by_id
=cut
sub load_by_phid {
my $self = shift;
my ( $conn, $phid ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
);
return $self->load_by_id( $conn, $phid );
}
=head2 insert
Instance method. Attempts to INSERT a record into the 'privhistory' table.
Field values are taken from the object. Returns a status object.
=cut
sub insert {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
my $status = cud(
conn => $context->{'dbix_conn'},
eid => $context->{'current'}->{'eid'},
object => $self,
sql => $site->SQL_PRIVHISTORY_INSERT,
attrs => [ 'eid', 'priv', 'effective', 'remark' ],
);
return $status;
lib/App/Dochazka/REST/Model/Privhistory.pm view on Meta::CPAN
=head2 update
Instance method. Updates the record. Returns status object.
=cut
sub update {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
my $status = cud(
conn => $context->{'dbix_conn'},
eid => $context->{'current'}->{'eid'},
object => $self,
sql => $site->SQL_PRIVHISTORY_UPDATE,
attrs => [ 'priv', 'effective', 'remark', 'phid' ],
);
return $status;
lib/App/Dochazka/REST/Model/Privhistory.pm view on Meta::CPAN
=head2 delete
Instance method. Deletes the record. Returns status object.
=cut
sub delete {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
my $status = cud(
conn => $context->{'dbix_conn'},
eid => $context->{'current'}->{'eid'},
object => $self,
sql => $site->SQL_PRIVHISTORY_DELETE,
attrs => [ 'phid' ],
);
$self->reset( 'phid' => $self->{phid} ) if $status->ok;
lib/App/Dochazka/REST/Model/Schedhistory.pm view on Meta::CPAN
Class method. Given an EID, and, optionally, a timestamp, attempt to
look it up in the database. Generate a status object: if a schedhistory
record is found, it will be in the payload and the code will be
'DISPATCH_RECORDS_FOUND'.
=cut
sub load_by_eid {
my $self = shift;
my ( $conn, $eid, $ts ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR }, # EID
{ type => SCALAR|UNDEF, optional => 1 }, # optional timestamp
);
if ( $ts ) {
return load(
conn => $conn,
class => __PACKAGE__,
sql => $site->SQL_SCHEDHISTORY_SELECT_ARBITRARY,
lib/App/Dochazka/REST/Model/Schedhistory.pm view on Meta::CPAN
=head2 load_by_id
Given a shid, load a single schedhistory record.
=cut
sub load_by_id {
my $self = shift;
my ( $conn, $shid ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR }
);
return load(
conn => $conn,
class => __PACKAGE__,
sql => $site->SQL_SCHEDHISTORY_SELECT_BY_SHID,
keys => [ $shid ],
);
lib/App/Dochazka/REST/Model/Schedhistory.pm view on Meta::CPAN
=head2 load_by_shid
Wrapper for load_by_id
=cut
sub load_by_shid {
my $self = shift;
my ( $conn, $shid ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR }
);
return $self->load_by_id( $conn, $shid );
}
=head2 insert
Instance method. Attempts to INSERT a record into the 'Schedhistory' table.
Field values are taken from the object. Returns a status object.
=cut
sub insert {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
my $status = cud(
conn => $context->{'dbix_conn'},
eid => $context->{'current'}->{'eid'},
object => $self,
sql => $site->SQL_SCHEDHISTORY_INSERT,
attrs => [ 'eid', 'sid', 'effective', 'remark' ],
);
return $status;
lib/App/Dochazka/REST/Model/Schedhistory.pm view on Meta::CPAN
=head2 update
Instance method. Updates the record. Returns status object.
=cut
sub update {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
my $status = cud(
conn => $context->{'dbix_conn'},
eid => $context->{'current'}->{'eid'},
object => $self,
sql => $site->SQL_SCHEDHISTORY_UPDATE,
attrs => [ 'sid', 'effective', 'remark', 'shid' ],
);
return $status;
lib/App/Dochazka/REST/Model/Schedhistory.pm view on Meta::CPAN
=head2 delete
Instance method. Deletes the record. Returns status object.
=cut
sub delete {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
my $status = cud(
conn => $context->{'dbix_conn'},
eid => $context->{'current'}->{'eid'},
object => $self,
sql => $site->SQL_SCHEDHISTORY_DELETE,
attrs => [ 'shid' ],
);
$self->reset( 'shid' => $self->{shid} ) if $status->ok;
lib/App/Dochazka/REST/Model/Schedintvls.pm view on Meta::CPAN
Instance method. Once the scratch intervals are inserted, we have a fully
populated object. This method runs each scratch interval through the stored
procedure 'translate_schedintvl' -- upon success, it creates a new attribute,
C<< $self->{schedule} >>, containing the translated intervals.
=cut
sub load {
my $self = shift;
my ( $conn ) = validate_pos( @_,
{ isa => 'DBIx::Connector' }
);
my $status;
my @results;
try {
$conn->run( fixup => sub {
# prepare and execute statement
my $sth = $_->prepare( $site->SQL_SCHEDINTVLS_SELECT );
$sth->execute( $self->{'ssid'} );
lib/App/Dochazka/REST/Model/Schedintvls.pm view on Meta::CPAN
=head2 insert
Instance method. Attempts to INSERT one or more records (one for each
interval in the 'intvls' attribute) into the 'schedintvls' table.
Field values are taken from the object. Returns a status object.
=cut
sub insert {
my $self = shift;
my ( $conn ) = validate_pos( @_,
{ isa => 'DBIx::Connector' }
);
# the insert operation needs to take place within a transaction,
# because all the intervals are inserted in one go
my $status;
try {
$conn->txn( fixup => sub {
my $sth = $_->prepare( $site->SQL_SCHEDINTVLS_INSERT );
my $intvls;
lib/App/Dochazka/REST/Model/Schedintvls.pm view on Meta::CPAN
=head2 delete
Instance method. Once we are done with the scratch intervals, they can be deleted.
Returns a status object.
=cut
sub delete {
my $self = shift;
my ( $conn ) = validate_pos( @_,
{ isa => 'DBIx::Connector' }
);
my $status;
try {
$conn->run( fixup => sub {
my $sth = $_->prepare( $site->SQL_SCHEDINTVLS_DELETE );
$sth->bind_param( 1, $self->ssid );
$sth->execute;
my $rows = $sth->rows;
lib/App/Dochazka/REST/Model/Schedule.pm view on Meta::CPAN
If the "schedule" field of the schedule to be inserted matches an existing
schedule, no new record is inserted. Instead, the existing schedule record
is returned. In such a case, the "scode", "remark", and "disabled" fields
are ignored - except when they are NULL in the existing record.
=cut
sub insert {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
# if the exact same schedule is already in the database, we
# don't insert it again
my $status = select_single(
conn => $context->{'dbix_conn'},
sql => $site->SQL_SCHEDULES_SELECT_BY_SCHEDULE,
keys => [ $self->{schedule} ],
);
$log->info( "select_single returned: " . Dumper $status );
if ( $status->level eq 'OK' ) {
lib/App/Dochazka/REST/Model/Schedule.pm view on Meta::CPAN
=head2 update
Although we do not allow the 'sid' or 'schedule' fields to be updated, schedule
records have 'scode', 'remark' and 'disabled' fields that can be updated via this
method.
=cut
sub update {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
return $CELL->status_err( 'DOCHAZKA_MALFORMED_400' ) unless $self->{'sid'};
my $status = cud(
conn => $context->{'dbix_conn'},
eid => $context->{'current'}->{'eid'},
object => $self,
sql => $site->SQL_SCHEDULE_UPDATE,
attrs => [ 'scode', 'remark', 'disabled', 'sid' ],
);
lib/App/Dochazka/REST/Model/Schedule.pm view on Meta::CPAN
=head2 delete
Instance method. Attempts to DELETE a schedule record. This may succeed
if no other records in the database refer to this schedule.
=cut
sub delete {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
my $status = cud(
conn => $context->{'dbix_conn'},
eid => $context->{'current'}->{'eid'},
object => $self,
sql => $site->SQL_SCHEDULE_DELETE,
attrs => [ 'sid' ],
);
$self->reset( sid => $self->{sid} ) if $status->ok;
lib/App/Dochazka/REST/Model/Schedule.pm view on Meta::CPAN
=head2 load_by_scode
Analogous function to L<App::Dochazka::REST::Model::Activity/"load_by_aid">.
=cut
sub load_by_scode {
my $self = shift;
my ( $conn, $scode ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
);
return load(
conn => $conn,
class => __PACKAGE__,
sql => $site->SQL_SCHEDULE_SELECT_BY_SCODE,
keys => [ $scode ],
);
lib/App/Dochazka/REST/Model/Schedule.pm view on Meta::CPAN
=head2 load_by_sid
Analogous function to L<App::Dochazka::REST::Model::Activity/"load_by_aid">.
=cut
sub load_by_sid {
my $self = shift;
my ( $conn, $sid ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
);
return load(
conn => $conn,
class => __PACKAGE__,
sql => $site->SQL_SCHEDULE_SELECT_BY_SID,
keys => [ $sid ],
);
lib/App/Dochazka/REST/Model/Schedule.pm view on Meta::CPAN
=head2 get_all_schedules
Returns a list of all schedule objects, ordered by sid. Takes one
argument - a paramhash that can contain only one key, 'disabled',
which can be either true or false (defaults to true).
=cut
sub get_all_schedules {
my %PH = validate( @_, {
conn => { isa => 'DBIx::Connector' },
disabled => { type => SCALAR, default => 0 }
} );
my $sql = $PH{disabled}
? $site->SQL_SCHEDULES_SELECT_ALL_INCLUDING_DISABLED
: $site->SQL_SCHEDULES_SELECT_ALL_EXCEPT_DISABLED;
# run the query and gather the results
lib/App/Dochazka/REST/Model/Shared.pm view on Meta::CPAN
=back
Returns a status object.
Important note: it is up to the programmer to not pass any SQL statement that
might affect more than one record.
=cut
sub cud {
my %ARGS = validate( @_, {
conn => { isa => 'DBIx::Connector' },
eid => { type => SCALAR },
object => { can => [ qw( insert delete ) ] },
sql => { type => SCALAR },
attrs => { type => ARRAYREF }, # order of attrs must match SQL statement
} );
my ( $status, $rv, $count );
try {
lib/App/Dochazka/REST/Model/Shared.pm view on Meta::CPAN
=back
Returns a status object.
Important note: it is up to the programmer to not pass any SQL statement that
might affect more than one record.
=cut
sub cud_generic {
my %ARGS = validate( @_, {
conn => { isa => 'DBIx::Connector' },
eid => { type => SCALAR },
sql => { type => SCALAR },
bind_params => { type => ARRAYREF, optional => 1 }, # order must match SQL statement
} );
$log->info( "Entering " . __PACKAGE__ . "::cud_generic with" );
$log->info( "sql: $ARGS{sql}" );
$log->info( "bind_param: " . Dumper( $ARGS{bind_params} ) );
my ( $status, $rv, $count );
lib/App/Dochazka/REST/Model/Shared.pm view on Meta::CPAN
Upon success, the payload will be a reference to an array of history
objects. If nothing is found, the array will be empty. If there is a DBI error,
the payload will be undefined.
=cut
sub get_history {
my $t = shift; # 'priv' or 'sched'
my $conn = shift;
validate_pos( @_, 1, 1, 0, 0, 0, 0 );
my %ARGS = validate( @_, {
eid => { type => SCALAR, optional => 1 },
nick => { type => SCALAR, optional => 1 },
tsrange => { type => SCALAR|UNDEF, optional => 1 },
} );
$log->debug("Entering get_history for $t - arguments: " . Dumper( \%ARGS ) );
my ( $sql, $sk, $status, $result, $tsr );
if ( exists $ARGS{'nick'} ) {
$sql = ($t eq 'priv')
lib/App/Dochazka/REST/Model/Shared.pm view on Meta::CPAN
=item * Database error
Level C<ERR>, code C<DOCHAZKA_DBI_ERR>, text: error message, payload: none
=back
=cut
sub load {
# get and verify arguments
my %ARGS = validate( @_, {
conn => { isa => 'DBIx::Connector' },
class => { type => SCALAR },
sql => { type => SCALAR },
keys => { type => ARRAYREF },
} );
# consult the database; N.B. - select may only return a single record
my ( $hr, $status );
try {
$ARGS{'conn'}->run( fixup => sub {
lib/App/Dochazka/REST/Model/Shared.pm view on Meta::CPAN
The return value will be a status object, the payload of which will be an
arrayref containing a set of objects. The objects are constructed by calling
$ARGS{'class'}->spawn
For convenience, a 'count' property will be included in the status object.
=cut
sub load_multiple {
# get and verify arguments
my %ARGS = validate( @_, {
conn => { isa => 'DBIx::Connector' },
class => { type => SCALAR },
sql => { type => SCALAR },
keys => { type => ARRAYREF },
} );
$log->debug( "Entering " . __PACKAGE__ . "::load_multiple" );
my $status;
my $results = [];
try {
lib/App/Dochazka/REST/Model/Shared.pm view on Meta::CPAN
The returned function takes a single argument: the search key (a scalar value).
If a record matching the search key is found, the corresponding object
(i.e. a true value) is returned. If such a record does not exist, 'undef' (a
false value) is returned. If there is a DBI error, the error text is logged
and undef is returned.
=cut
sub make_test_exists {
my ( $t ) = validate_pos( @_, { type => SCALAR } );
my $pkg = (caller)[0];
return sub {
my ( $conn, $s_key ) = @_;
require Try::Tiny;
my $routine = "load_by_$t";
my ( $status, $txt );
$log->debug( "Entered $t" . "_exists with search key $s_key" );
try {
no strict 'refs';
lib/App/Dochazka/REST/Model/Shared.pm view on Meta::CPAN
the total number of records in the table.
activities employees intervals locks privhistory schedhistory
schedintvls schedules tempintvls
On failure, returns undef.
=cut
sub noof {
my ( $conn, $table ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR }
);
return unless grep { $table eq $_; } qw( activities employees intervals locks
privhistory schedhistory schedintvls schedules tempintvls );
my $count;
try {
$conn->run( fixup => sub {
lib/App/Dochazka/REST/Model/Shared.pm view on Meta::CPAN
=head2 priv_by_eid
Given an EID, and, optionally, a timestamp, returns the employee's priv
level as of that timestamp, or as of "now" if no timestamp was given. The
priv level will default to 'passerby' if it can't be determined from the
database.
=cut
sub priv_by_eid {
my ( $conn, $eid, $ts ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
{ type => SCALAR|UNDEF, optional => 1 }
);
#$log->debug( "priv_by_eid: EID is " . (defined( $eid ) ? $eid : 'undef') . " - called from " . (caller)[1] . " line " . (caller)[2] );
return _st_by_eid( $conn, 'priv', $eid, $ts );
}
=head2 schedule_by_eid
Given an EID, and, optionally, a timestamp, returns the SID of the employee's
schedule as of that timestamp, or as of "now" if no timestamp was given.
=cut
sub schedule_by_eid {
my ( $conn, $eid, $ts ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
{ type => SCALAR|UNDEF, optional => 1 },
);
return _st_by_eid( $conn, 'schedule', $eid, $ts );
}
=head3 _st_by_eid
lib/App/Dochazka/REST/Model/Shared.pm view on Meta::CPAN
Given a L<DBIx::Connector> object in the 'conn' property, a SELECT statement in
the 'sql' property and, in the 'keys' property, an arrayref containing a list
of scalar values to plug into the SELECT statement, run a C<selectrow_array>
and return the resulting list.
Returns a standard status object (see C<load> routine, above, for description).
=cut
sub select_single {
my %ARGS = validate( @_, {
conn => { isa => 'DBIx::Connector' },
sql => { type => SCALAR },
keys => { type => ARRAYREF },
} );
my ( $status, @results );
$log->info( "select_single keys: " . Dumper( $ARGS{keys} ) );
try {
$ARGS{'conn'}->run( fixup => sub {
@results = $_->selectrow_array( $ARGS{'sql'}, undef, @{ $ARGS{'keys'} } );
} );
lib/App/Dochazka/REST/Model/Shared.pm view on Meta::CPAN
=head2 select_set_of_single_scalar_rows
Given DBIx::Connector object, an SQL statement, and a set of keys to bind
into the SQL statement, assume that the statement can return 0-n records
and that each record consists of a single field that must fit into a single
scalar value.
=cut
sub select_set_of_single_scalar_rows {
my %ARGS = validate( @_, {
conn => { isa => 'DBIx::Connector' },
sql => { type => SCALAR },
keys => { type => ARRAYREF },
} );
$log->debug( "Entering " . __PACKAGE__ . "::select_set_of_single_scalar_rows with
paramhash " . Dumper( \%ARGS ) );
my ( $status, $result_set );
try {
$ARGS{'conn'}->run( fixup => sub {
lib/App/Dochazka/REST/Model/Shared.pm view on Meta::CPAN
Given a timestamp string and an interval string (e.g. "1 week 3 days" ),
subtract the interval from the timestamp.
Returns a status object. If the database operation is successful, the payload
will contain the resulting timestamp.
=cut
sub timestamp_delta_minus {
my ( $conn, $ts, $delta ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
{ type => SCALAR },
);
$log->info( "timestamp_delta_minus: timestamp $ts, delta $delta" );
my $status = select_single(
conn => $conn,
sql => "SELECT CAST( ? AS timestamptz ) - CAST( ? AS interval )",
keys => [ $ts, $delta ],
);
lib/App/Dochazka/REST/Model/Shared.pm view on Meta::CPAN
Given a timestamp string and an interval string (e.g. "1 week 3 days" ),
add the interval to the timestamp.
Returns a status object. If the database operation is successful, the payload
will contain the resulting timestamp.
=cut
sub timestamp_delta_plus {
my ( $conn, $ts, $delta ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
{ type => SCALAR },
);
$log->info( "timestamp_delta_plus: timestamp $ts, delta $delta" );
my $status = select_single(
conn => $conn,
sql => "SELECT CAST( ? AS timestamptz ) + CAST( ? AS interval )",
keys => [ $ts, $delta ],
);
lib/App/Dochazka/REST/Model/Tempintvl.pm view on Meta::CPAN
=head2 delete
Attempts to the delete the record (in the tempintvls table) corresponding
to the object. Returns a status object.
=cut
sub delete {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
my $status = cud(
conn => $context->{'dbix_conn'},
eid => $context->{'current'}->{'eid'},
object => $self,
sql => $site->SQL_TEMPINTVL_DELETE_SINGLE,
attrs => [ 'int_id' ],
);
$self->reset( int_id => $self->{int_id} ) if $status->ok;
lib/App/Dochazka/REST/Model/Tempintvl.pm view on Meta::CPAN
=head2 insert
Instance method. Attempts to INSERT a record. Field values are taken from the
object. Returns a status object.
=cut
sub insert {
my $self = shift;
my ( $context ) = validate_pos( @_, { type => HASHREF } );
my $status = cud(
conn => $context->{'dbix_conn'},
eid => $context->{'current'}->{'eid'},
object => $self,
sql => $site->SQL_TEMPINTVL_INSERT,
attrs => [ 'tiid', 'intvl' ],
);
return $status;
lib/App/Dochazka/REST/Model/Tempintvl.pm view on Meta::CPAN
=head2 fetch_tempintvls_by_tiid_and_tsrange
Given a L<DBIx::Connector> object, a tiid and a tsrange, return the set
(array) of C<tempintvl> objects that match the tiid and tsrange.
=cut
sub fetch_tempintvls_by_tiid_and_tsrange {
my ( $conn, $tiid, $tsrange ) = validate_pos( @_,
{ isa => 'DBIx::Connector' },
{ type => SCALAR },
{ type => SCALAR },
);
my $status = canonicalize_tsrange( $conn, $tsrange );
return $status unless $status->ok;
$tsrange = $status->payload;
$status = load_multiple(
lib/App/Dochazka/REST/ResourceDefs.pm view on Meta::CPAN
The "POST genreport" resource generates reports from Mason templates.
The resource takes a request body with one mandatory property, "path"
(corresponding to the path of a Mason component relative to the component
root), and one optional property, "parameters", which should be a hash
of parameter names and values.
The resource handler checks (1) if the component exists in the database,
(2) whether current employee has sufficient permissions to generate the
report (by comparing the employee's privlevel with the ACL profile of the
component), and (3) validates the parameters, if any, by applying the
validation rules specified in the component object. Iff all of these
conditions are met, the component is called with the provided parameters.
EOH
},
};
=head2 History resources
lib/App/Dochazka/REST/Shared.pm view on Meta::CPAN
Called from handlers in L<App::Dochazka::REST::Dispatch>. Takes three arguments:
- $d_obj is the App::Dochazka::REST::Dispatch object
- $ignore_me will be undef
- $new_emp_props is a hashref with employee properties and their values (guaranteed to contain 'nick')
=cut
sub shared_insert_employee {
$log->debug( "Entered " . __PACKAGE__ . "::shared_insert_employee" );
my ( $d_obj, $ignore_me, $new_emp_props ) = validate_pos( @_,
{ isa => 'App::Dochazka::REST::Dispatch' },
{ type => UNDEF },
{ type => HASHREF },
);
$log->debug( "Arguments are OK, about to insert new employee: " . Dumper( $new_emp_props ) );
# If there is a "password" property, transform it into "passhash" + "salt"
hash_the_password( $new_emp_props );
# spawn an object, filtering the properties first
lib/App/Dochazka/REST/Shared.pm view on Meta::CPAN
- $d_obj is the dispatch (App::Dochazka::REST::Dispatch) object
- $sched is a schedule object (blessed hashref)
- $over is a hashref with zero or more schedule properties and new values
The values from C<$over> replace those in C<$emp>.
=cut
sub shared_update_schedule {
my ( $d_obj, $sched, $over ) = validate_pos( @_,
{ isa => 'App::Dochazka::REST::Dispatch' },
{ isa => 'App::Dochazka::REST::Model::Schedule' },
{ type => HASHREF },
);
$log->debug("Entering " . __PACKAGE__ . "::shared_update_schedule" );
delete $over->{'sid'} if exists $over->{'sid'};
delete $over->{'schedule'} if exists $over->{'schedule'};
if ( pre_update_comparison( $sched, $over ) ) {
$log->debug( "After pre_update_comparison: " . Dumper $sched );
lib/App/Dochazka/REST/Shared.pm view on Meta::CPAN
=head2 shared_insert_activity
Takes two arguments: the dispatch object and the properties that are supposed
to be an activity object to be inserted.
=cut
sub shared_insert_activity {
my ( $d_obj, $code, $props ) = validate_pos( @_,
{ isa => 'App::Dochazka::REST::Dispatch' },
{ type => SCALAR },
{ type => HASHREF },
);
$log->debug("Reached " . __PACKAGE__ . "::shared_insert_activity" );
my %proplist_before = %$props;
$proplist_before{'code'} = $code; # overwrite whatever might have been there
$log->debug( "Properties before filter: " . join( ' ', keys %proplist_before ) );
lib/App/Dochazka/REST/Shared.pm view on Meta::CPAN
=head2 shared_insert_component
Takes two arguments: the dispatch object and the properties that are supposed
to be a component object to be inserted.
=cut
sub shared_insert_component {
my ( $d_obj, $path, $props ) = validate_pos( @_,
{ isa => 'App::Dochazka::REST::Dispatch' },
{ type => SCALAR },
{ type => HASHREF },
);
$log->debug("Reached " . __PACKAGE__ . "::shared_insert_component" );
my %proplist_before = %$props;
$proplist_before{'path'} = $path; # overwrite whatever might have been there
$log->debug( "Properties before filter: " . join( ' ', keys %proplist_before ) );
lib/App/Dochazka/REST/Test.pm view on Meta::CPAN
* HTTP method
* resource string
* optional JSON string
If the HTTP result code is 200, the return value will be a status object, undef
otherwise.
=cut
sub req {
my ( $test, $code, $user, $method, $resource, $json ) = validate_pos( @_, 1, 1, 1, 1, 1, 0 );
if ( ref( $test ) ne 'Plack::Test::MockHTTP' ) {
diag( "Plack::Test::MockHTTP object not passed to 'req' from " . (caller)[1] . " line " . (caller)[2] );
BAIL_OUT(0);
}
# assemble request
my %pl = (
Accept => 'application/json',
Content_Type => 'application/json',
lib/App/Dochazka/REST/Test.pm view on Meta::CPAN
expected to return DOCHAZKA_DBI_ERR. In addition to the arguments expected
by 'req', takes one additional argument, which should be:
qr/error message subtext/
(i.e. a regex quote by which to test the $status->text)
=cut
sub dbi_err {
my ( $test, $code, $user, $method, $resource, $json, $qr ) = validate_pos( @_, 1, 1, 1, 1, 1, 1, 1 );
my $status = req( $test, $code, $user, $method, $resource, $json );
is( $status->level, 'ERR' );
ok( $status->text );
if ( ! ( $status->text =~ $qr ) ) {
diag( "$user $method $resource\n$json" );
diag( $status->text . " does not match $qr" );
BAIL_OUT(0);
}
like( $status->text, $qr );
}
lib/App/Dochazka/REST/Test.pm view on Meta::CPAN
For use in tests only. Spawns an employee object and inserts it into the
database.
Takes PROPLIST which is passed through unmunged to the employee spawn method.
Returns the new Employee object.
=cut
sub create_bare_employee {
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 ) {
t/dispatch/001-resource.t view on Meta::CPAN
is_deeply( $resource_self->context, {} );
$resource_self->context( { 'bubba' => 'BAAAA' } );
is( $resource_self->context->{'bubba'}, 'BAAAA' );
note( 'test if the \'no_cache\' headers are present in each response' );
$r = GET '/', 'Accept' => 'application/json', 'Content_Type' => 'application/json';
isa_ok( $r, 'HTTP::Request' );
$r->authorization_basic( 'root', 'immutable' );
$resp = $test->request( $r );
isa_ok( $resp, 'HTTP::Response' );
is( $resp->header( 'Cache-Control' ), 'no-cache, no-store, must-revalidate, private' );
is( $resp->header( 'Pragma' ), 'no-cache' );
done_testing;
( run in 0.693 second using v1.01-cache-2.11-cpan-a5abf4f5562 )