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