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