Open-ILS/src/perlmods/OpenILS/Utils/Editor.pm

   1 use strict; use warnings;
   2 package OpenILS::Utils::Editor;
   3 use OpenILS::Application::AppUtils;
   4 use OpenSRF::AppSession;
   5 use OpenSRF::EX qw(:try);
   6 use OpenILS::Utils::Fieldmapper;
   7 use OpenILS::Event;
   8 use Data::Dumper;
   9 use OpenSRF::Utils::JSON;
  10 use OpenSRF::Utils::Logger qw($logger);
  11 my $U = "OpenILS::Application::AppUtils";
  12
  13
  14 # -----------------------------------------------------------------------------
  15 # Export some useful functions
  16 # -----------------------------------------------------------------------------
  17 use vars qw(@EXPORT_OK %EXPORT_TAGS);
  18 use Exporter;
  19 use base qw/Exporter/;
  20 push @EXPORT_OK, 'new_editor';
  21 %EXPORT_TAGS = ( funcs => [ qw/ new_editor / ] );
  22
  23 sub new_editor { return OpenILS::Utils::Editor->new(@_); }
  24
  25
  26 # -----------------------------------------------------------------------------
  27 # These need to be auto-generated
  28 # -----------------------------------------------------------------------------
  29 my %PERMS = (
  30         'biblio.record_entry'   => { update => 'UPDATE_MARC' },
  31         'asset.copy'                            => { update => 'UPDATE_COPY'},
  32         'asset.call_number'             => { update => 'UPDATE_VOLUME'},
  33         'action.circulation'            => { retrieve => 'VIEW_CIRCULATIONS'},
  34 );
  35
  36 my $logstr;
  37 use constant E => 'error';
  38 use constant W => 'warn';
  39 use constant I => 'info';
  40 use constant D => 'debug';
  41 use constant A => 'activity';
  42
  43
  44
  45 # -----------------------------------------------------------------------------
  46 # Params include:
  47 #       xact=><true> : creates a storage transaction
  48 #       authtoken=>$token : the login session key
  49 # -----------------------------------------------------------------------------
  50 sub new {
  51         my( $class, %params ) = @_;
  52         $class = ref($class) || $class;
  53         my $self = bless( \%params, $class );
  54         $self->{checked_perms} = {};
  55         $logstr = "editor [0";
  56         $logstr = "editor [1" if $self->{xact};
  57         return $self;
  58 }
  59
  60 # -----------------------------------------------------------------------------
  61 # Log the editor metadata along with the log string
  62 # -----------------------------------------------------------------------------
  63 sub log {
  64         my( $self, $lev, $str ) = @_;
  65         my $s = "editor[";
  66         $s .= "0|" unless $self->{xact};
  67         $s .= "1|" if $self->{xact};
  68         $s .= "0" unless $self->requestor;
  69         $s .= $self->requestor->id if $self->requestor;
  70         $s .= "]";
  71         $logger->$lev("$s $str");
  72 }
  73
  74 # -----------------------------------------------------------------------------
  75 # Verifies the auth token and fetches the requestor object
  76 # -----------------------------------------------------------------------------
  77 sub checkauth {
  78         my $self = shift;
  79         $self->log(D, "checking auth token ".$self->authtoken);
  80         my ($reqr, $evt) = $U->checkses($self->authtoken);
  81         $self->event($evt) if $evt;
  82         return $self->{requestor} = $reqr;
  83 }
  84
  85
  86 # -----------------------------------------------------------------------------
  87 # Returns the last generated event
  88 # -----------------------------------------------------------------------------
  89 sub event {
  90         my( $self, $evt ) = @_;
  91         $self->{event} = $evt if $evt;
  92         return $self->{event};
  93 }
  94
  95 # -----------------------------------------------------------------------------
  96 # Clears the last caught event
  97 # -----------------------------------------------------------------------------
  98 sub clear_event {
  99         my $self = shift;
 100         $self->{event} = undef;
 101 }
 102
 103 sub authtoken {
 104         my( $self, $auth ) = @_;
 105         $self->{authtoken} = $auth if $auth;
 106         return $self->{authtoken};
 107 }
 108
 109 # -----------------------------------------------------------------------------
 110 # fetches the session, creating if necessary.  If 'xact' is true on this
 111 # object, a db session is created
 112 # -----------------------------------------------------------------------------
 113 sub session {
 114         my( $self, $session ) = @_;
 115         $self->{session} = $session if $session;
 116
 117         if(!$self->{session}) {
 118                 $self->{session} = OpenSRF::AppSession->create('open-ils.storage');
 119
 120                 if( ! $self->{session} ) {
 121                         my $str = "Error creating storage session with OpenSRF::AppSession->create()!";
 122                         $self->log(E, $str);
 123                         throw OpenSRF::EX::ERROR ($str);
 124                 }
 125
 126                 $self->{session}->connect if $self->{xact} or $self->{connect};
 127                 $self->xact_start if $self->{xact};
 128         }
 129         return $self->{session};
 130 }
 131
 132
 133 # -----------------------------------------------------------------------------
 134 # Starts a storage transaction
 135 # -----------------------------------------------------------------------------
 136 sub xact_start {
 137         my $self = shift;
 138         $self->log(D, "starting new db session");
 139         my $stat = $self->request('open-ils.storage.transaction.begin');
 140         $self->log(E, "error starting database transaction") unless $stat;
 141         return $stat;
 142 }
 143
 144 # -----------------------------------------------------------------------------
 145 # Commits a storage transaction
 146 # -----------------------------------------------------------------------------
 147 sub xact_commit {
 148         my $self = shift;
 149         $self->log(D, "comitting db session");
 150         my $stat = $self->request('open-ils.storage.transaction.commit');
 151         $self->log(E, "error comitting database transaction") unless $stat;
 152         return $stat;
 153 }
 154
 155 # -----------------------------------------------------------------------------
 156 # Rolls back a storage stransaction
 157 # -----------------------------------------------------------------------------
 158 sub xact_rollback {
 159         my $self = shift;
 160         $self->log(I, "rolling back db session");
 161         return $self->request("open-ils.storage.transaction.rollback");
 162 }
 163
 164
 165 # -----------------------------------------------------------------------------
 166 # commits the db session and destroys the session
 167 # -----------------------------------------------------------------------------
 168 sub commit {
 169         my $self = shift;
 170         return unless $self->{xact};
 171         $self->xact_commit;
 172         $self->session->disconnect;
 173         $self->{session} = undef;
 174 }
 175
 176 # -----------------------------------------------------------------------------
 177 # clears all object data. Does not commit the db transaction.
 178 # -----------------------------------------------------------------------------
 179 sub reset {
 180         my $self = shift;
 181         $self->session->disconnect if $self->{session};
 182         $$self{$_} = undef for (keys %$self);
 183 }
 184
 185
 186 # -----------------------------------------------------------------------------
 187 # commits and resets
 188 # -----------------------------------------------------------------------------
 189 sub finish {
 190         my $self = shift;
 191         $self->commit;
 192         $self->reset;
 193 }
 194
 195
 196
 197 # -----------------------------------------------------------------------------
 198 # Does a simple storage request
 199 # -----------------------------------------------------------------------------
 200 sub request {
 201         my( $self, $method, @params ) = @_;
 202
 203         my $val;
 204         my $err;
 205         my $argstr = __arg_to_string( (scalar(@params)) == 1 ? $params[0] : \@params);
 206
 207         $self->log(I, "request $method : $argstr");
 208
 209         try {
 210                 $val = $self->session->request($method, @params)->gather(1);
 211
 212         } catch Error with {
 213                 $err = shift;
 214                 $self->log(E, "request error $method : $argstr : $err");
 215         };
 216
 217         throw $err if $err;
 218         return $val;
 219 }
 220
 221
 222 # -----------------------------------------------------------------------------
 223 # Sets / Returns the requstor object.  This is set when checkauth succeeds.
 224 # -----------------------------------------------------------------------------
 225 sub requestor {
 226         my($self, $requestor) = @_;
 227         $self->{requestor} = $requestor if $requestor;
 228         return $self->{requestor};
 229 }
 230
 231
 232
 233 # -----------------------------------------------------------------------------
 234 # Holds the last data received from a storage call
 235 # -----------------------------------------------------------------------------
 236 sub data {
 237         my( $self, $data ) = @_;
 238         $self->{data} = $data if defined $data;
 239         return $self->{data};
 240 }
 241
 242
 243 # -----------------------------------------------------------------------------
 244 # True if this perm has already been checked at this org
 245 # -----------------------------------------------------------------------------
 246 sub perm_checked {
 247         my( $self, $perm, $org ) = @_;
 248         $self->{checked_perms}->{$org} = {}
 249                 unless $self->{checked_perms}->{$org};
 250         my $checked = $self->{checked_perms}->{$org}->{$perm};
 251         if(!$checked) {
 252                 $self->{checked_perms}->{$org}->{$perm} = 1;
 253                 return 0;
 254         }
 255         return 1;
 256 }
 257
 258
 259
 260 # -----------------------------------------------------------------------------
 261 # Returns true if the requested perm is allowed.  If the perm check fails,
 262 # $e->event is set and undef is returned
 263 # The perm user is $e->requestor->id and perm org defaults to the requestor's
 264 # ws_ou
 265 # If this perm at the given org has already been verified, true is returned
 266 # and the perm is not re-checked
 267 # -----------------------------------------------------------------------------
 268 sub allowed {
 269         my( $self, $perm, $org ) = @_;
 270         my $uid = $self->requestor->id;
 271         $org ||= $self->requestor->ws_ou;
 272         $self->log(I, "checking perms user=$uid, org=$org, perm=$perm");
 273         return 1 if $self->perm_checked($perm, $org);
 274         return $self->checkperm($uid, $org, $perm);
 275 }
 276
 277 sub checkperm {
 278         my($self, $userid, $org, $perm) = @_;
 279         my $s = $self->request(
 280                 "open-ils.storage.permission.user_has_perm", $userid, $perm, $org );
 281
 282         if(!$s) {
 283                 my $e = OpenILS::Event->new('PERM_FAILURE', ilsperm => $perm, ilspermloc => $org);
 284                 $self->event($e);
 285                 return undef;
 286         }
 287
 288         return 1;
 289 }
 290
 291
 292
 293 # -----------------------------------------------------------------------------
 294 # checks the appropriate perm for the operation
 295 # -----------------------------------------------------------------------------
 296 sub _checkperm {
 297         my( $self, $ptype, $action, $org ) = @_;
 298         $org ||= $self->requestor->ws_ou;
 299         my $perm = $PERMS{$ptype}{$action};
 300         if( $perm ) {
 301                 return undef if $self->perm_checked($perm, $org);
 302                 return $self->event unless $self->allowed($perm, $org);
 303         } else {
 304                 $self->log(E, "no perm provided for $ptype.$action");
 305         }
 306         return undef;
 307 }
 308
 309
 310
 311 # -----------------------------------------------------------------------------
 312 # Logs update actions to the activity log
 313 # -----------------------------------------------------------------------------
 314 sub log_activity {
 315         my( $self, $type, $action, $arg ) = @_;
 316         my $str = "$type.$action";
 317         $str .= _prop_string($arg);
 318         $self->log(A, $str);
 319 }
 320
 321
 322
 323 sub _prop_string {
 324         my $obj = shift;
 325         my @props = $obj->properties;
 326         my $str = "";
 327         for(@props) {
 328                 my $prop = $obj->$_() || "";
 329                 $prop = substr($prop, 0, 128) . "..." if length $prop > 131;
 330                 $str .= " $_=$prop";
 331         }
 332         return $str;
 333 }
 334
 335
 336 sub __arg_to_string {
 337         my $arg = shift;
 338         return "" unless defined $arg;
 339         return $arg->id if UNIVERSAL::isa($arg, "Fieldmapper");
 340         return OpenSRF::Utils::JSON->perl2JSON($arg);
 341 }
 342
 343
 344 # -----------------------------------------------------------------------------
 345 # This does the actual storage query.
 346 #
 347 # 'search' calls become search_where calls and $arg can be a search hash or
 348 # an array-ref of storage search options.
 349 #
 350 # 'retrieve' expects an id
 351 # 'update' expects an object
 352 # 'create' expects an object
 353 # 'delete' expects an object
 354 #
 355 # All methods return true on success and undef on failure.  On failure,
 356 # $e->event is set to the generated event.
 357 # Note: this method assumes that updating a non-changed object and
 358 # thereby receiving a 0 from storage, is a successful update.
 359 #
 360 # The method will therefore return true so the caller can just do
 361 # $e->update_blah($x) or return $e->event;
 362 # The true value returned from storage for all methods will be stored in
 363 # $e->data, until the next method is called.
 364 #
 365 # not-found events are generated on retrieve and serach methods.
 366 # action=search methods will return [] (==true) if no data is found.  If the
 367 # caller is interested in the not found event, they can do:
 368 # return $e->event unless @$results;
 369 # -----------------------------------------------------------------------------
 370 sub runmethod {
 371         my( $self, $action, $type, $arg, $options ) = @_;
 372
 373         my @arg = ($arg);
 374         my $method = "open-ils.storage.direct.$type.$action";
 375
 376         if( $action eq 'search' ) {
 377                 $method =~ s/search/search_where/o;
 378                 $method =~ s/direct/id_list/o if $options->{idlist};
 379                 $method = "$method.atomic";
 380                 @arg = @$arg if ref($arg) eq 'ARRAY';
 381
 382         } elsif( $action eq 'batch_retrieve' ) {
 383                 $method =~ s/batch_retrieve/batch.retrieve/o;
 384                 $method = "$method.atomic";
 385                 @arg = @$arg if ref($arg) eq 'ARRAY';
 386
 387         } elsif( $action eq 'retrieve_all' ) {
 388                 $method =~ s/retrieve_all/retrieve.all.atomic/o;
 389         }
 390
 391         # remove any stale events
 392         $self->clear_event;
 393
 394         if( $action eq 'update' or $action eq 'delete' or $action eq 'create' ) {
 395                 $self->log_activity($type, $action, $arg);
 396         }
 397
 398         if($$options{checkperm}) {
 399                 my $a = ($action eq 'search' or
 400                         $action eq 'batch_retrieve' or $action eq 'retrieve_all') ? 'retrieve' : $action;
 401                 my $e = $self->_checkperm($type, $a, $$options{permorg});
 402                 if($e) {
 403                         $self->event($e);
 404                         return undef;
 405                 }
 406         }
 407
 408         my $obj;
 409         my $err;
 410
 411         try {
 412                 $obj = $self->request($method, @arg);
 413         } catch Error with { $err = shift; };
 414
 415
 416         if(!defined $obj) {
 417                 $self->log(I, "request returned no data");
 418
 419                 if( $action eq 'retrieve' ) {
 420                         $self->event(_mk_not_found($type, $arg));
 421
 422                 } elsif( $action eq 'update' or
 423                                 $action eq 'delete' or $action eq 'create' ) {
 424                         my $evt = OpenILS::Event->new(
 425                                 'DATABASE_UPDATE_FAILED', payload => $arg, debug => "$err" );
 426                         $self->event($evt);
 427                 }
 428
 429                 if( $err ) {
 430                         $self->event(
 431                                 OpenILS::Event->new( 'DATABASE_QUERY_FAILED',
 432                                         payload => $arg, debug => "$err" ));
 433                         return undef;
 434                 }
 435
 436                 return undef;
 437         }
 438
 439         if( $action eq 'create' and $obj == 0 ) {
 440                 my $evt = OpenILS::Event->new(
 441                         'DATABASE_UPDATE_FAILED', payload => $arg, debug => "$err" );
 442                 $self->event($evt);
 443                 return undef;
 444         }
 445
 446         # If we havn't dealt with the error in a nice way, go ahead and throw it
 447         if( $err ) {
 448                 $self->event(
 449                         OpenILS::Event->new( 'DATABASE_QUERY_FAILED',
 450                                 payload => $arg, debug => "$err" ));
 451                 return undef;
 452         }
 453
 454         if( $action eq 'search' or $action eq 'batch_retrieve' or $action eq 'retrieve_all') {
 455                 $self->log(I, "$type.$action : returned ".scalar(@$obj). " result(s)");
 456                 $self->event(_mk_not_found($type, $arg)) unless @$obj;
 457         }
 458
 459         $arg->id($obj) if $action eq 'create'; # grabs the id on create
 460         $self->data($obj); # cache the data for convenience
 461
 462         return ($obj) ? $obj : 1;
 463 }
 464
 465
 466 sub _mk_not_found {
 467         my( $type, $arg ) = @_;
 468         (my $t = $type) =~ s/\./_/og;
 469         $t = uc($t);
 470         return OpenILS::Event->new("${t}_NOT_FOUND", payload => $arg);
 471 }
 472
 473
 474
 475 # utility method for loading
 476 sub __fm2meth {
 477         my $str = shift;
 478         my $sep = shift;
 479         $str =~ s/Fieldmapper:://o;
 480         $str =~ s/::/$sep/g;
 481         return $str;
 482 }
 483
 484
 485 # -------------------------------------------------------------
 486 # Load up the methods from the FM classes
 487 # -------------------------------------------------------------
 488 my $map = $Fieldmapper::fieldmap;
 489 for my $object (keys %$map) {
 490         my $obj = __fm2meth($object,'_');
 491         my $type = __fm2meth($object, '.');
 492
 493         my $update = "update_$obj";
 494         my $updatef =
 495                 "sub $update {return shift()->runmethod('update', '$type', \@_);}";
 496         eval $updatef;
 497
 498         my $retrieve = "retrieve_$obj";
 499         my $retrievef =
 500                 "sub $retrieve {return shift()->runmethod('retrieve', '$type', \@_);}";
 501         eval $retrievef;
 502
 503         my $search = "search_$obj";
 504         my $searchf =
 505                 "sub $search {return shift()->runmethod('search', '$type', \@_);}";
 506         eval $searchf;
 507
 508         my $create = "create_$obj";
 509         my $createf =
 510                 "sub $create {return shift()->runmethod('create', '$type', \@_);}";
 511         eval $createf;
 512
 513         my $delete = "delete_$obj";
 514         my $deletef =
 515                 "sub $delete {return shift()->runmethod('delete', '$type', \@_);}";
 516         eval $deletef;
 517
 518         my $bretrieve = "batch_retrieve_$obj";
 519         my $bretrievef =
 520                 "sub $bretrieve {return shift()->runmethod('batch_retrieve', '$type', \@_);}";
 521         eval $bretrievef;
 522
 523         my $retrieveall = "retrieve_all_$obj";
 524         my $retrieveallf =
 525                 "sub $retrieveall {return shift()->runmethod('retrieve_all', '$type', \@_);}";
 526         eval $retrieveallf;
 527
 528
 529 }
 530
 531
 532
 533 1;
 534
 535