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