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

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