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