lib/Vend/SOAP.pm

   1 # Vend::SOAP - Handle SOAP connections for Interchange
   2 #
   3 # $Id: SOAP.pm,v 2.18 2007-08-09 13:40:54 pajamian Exp $
   4 #
   5 # Copyright (C) 2002-2007 Interchange Development Group
   6 # Copyright (C) 2000-2002 Red Hat, Inc.
   7 #
   8 # This program is free software; you can redistribute it and/or modify
   9 # it under the terms of the GNU General Public License as published by
  10 # the Free Software Foundation; either version 2 of the License, or
  11 # (at your option) any later version.
  12 #
  13 # This program is distributed in the hope that it will be useful,
  14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 # GNU General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public
  19 # License along with this program; if not, write to the Free
  20 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  21 # MA  02110-1301  USA.
  22
  23 package Vend::SOAP;
  24
  25 require AutoLoader;
  26
  27 use Vend::Util;
  28 use Vend::Interpolate;
  29 use Vend::Order;
  30 use HTTP::Response;
  31 use HTTP::Headers;
  32 use Vend::SOAP::Transport;
  33 require SOAP::Transport::IO;
  34 require SOAP::Transport::HTTP;
  35 use strict;
  36
  37 use vars qw($VERSION @ISA $AUTOLOAD);
  38 $VERSION = substr(q$Revision: 2.18 $, 10);
  39 @ISA = qw/SOAP::Server/;
  40
  41 my %Allowed_tags;
  42 my @Allowed_tags = qw/
  43 accessories
  44 area
  45 cart
  46 counter
  47 currency
  48 data
  49 description
  50 discount
  51 dump
  52 error
  53 export
  54 field
  55 filter
  56 fly_list
  57 fly_tax
  58 handling
  59 import
  60 index
  61 input_filter
  62 item_list
  63 label
  64 log
  65 loop
  66 mail
  67 nitems
  68 onfly
  69 options
  70 order
  71 page
  72 price
  73 process
  74 profile
  75 query
  76 record
  77 salestax
  78 scratch
  79 scratchd
  80 selected
  81 set
  82 setlocale
  83 shipping
  84 shipping_desc
  85 subtotal
  86 time
  87 total_cost
  88 tree
  89 update
  90 userdb
  91 value
  92 value_extended
  93 /;
  94
  95 for (@Allowed_tags) {
  96         $Allowed_tags{$_} = 1;
  97 }
  98
  99 sub hello {
 100         my $self = shift;
 101         my @args = @_;
 102         return "hello from the Vend::SOAP server, pid $$, world!\nreceived args:\n"
 103                 . uneval(\@args);
 104 }
 105
 106 sub soaptest {
 107         my $self = shift;
 108         my @args = @_;
 109         return @args;
 110 }
 111
 112 sub tag_soap {
 113         my ($method, $uri, $proxy, $opt) = @_;
 114         my @args;
 115         if($opt->{param}) {
 116                 if (ref($opt->{param}) eq 'ARRAY') {
 117                         @args = @{$opt->{param}};
 118                 }
 119                 elsif (ref($opt->{param}) eq 'HASH') {
 120                         @args = %{$opt->{param}};
 121                 }
 122                 else {
 123                         @args = $opt->{param};
 124                 }
 125         }
 126         else {
 127                 @args = $opt;
 128         }
 129
 130         if($opt->{trace_transport}) {
 131                 if (exists $Vend::Cfg->{Sub}->{$opt->{trace_transport}}) {
 132                         SOAP::Trace->import('transport' => $Vend::Cfg->{Sub}->{$opt->{trace_transport}});
 133                 } else {
 134                         ::logError (qq{no such subroutine "$opt->{trace_transport}" for SOAP transport tracing});
 135                 }
 136         }
 137
 138         my $result;
 139 #::logDebug("to method call, uri=$uri proxy=$proxy call=$method args=" . ::uneval(\@args));
 140         eval {
 141                 if(! $method ) {
 142                         $result = SOAP::Lite
 143                                         -> uri($uri)
 144                                         -> proxy($proxy)
 145                                         -> call ('init');
 146                 }
 147                 elsif(ref $opt->{object}) {
 148                         $result = $opt->{object}
 149                                         -> uri($uri)
 150                                         -> proxy($proxy)
 151                                         -> call( $method => @args )
 152                                         -> result;
 153                 }
 154                 else {
 155                         $result = SOAP::Lite
 156                                         -> uri($uri)
 157                                         -> proxy($proxy)
 158                                         -> call( $method => @args )
 159                                         -> result;
 160                 }
 161         };
 162         if($@) {
 163                 ::logError("error on SOAP call: %s", $@);
 164         }
 165 #::logDebug("after method call, uri=$uri proxy=$proxy call=$method result=$result");
 166
 167         $::Scratch->{$opt->{result}} = $result if $opt->{result};
 168         return '' if $opt->{init};
 169         return $result;
 170 }
 171
 172 sub tag_soap_entity {
 173         my ($opt) = @_;
 174         my ($obj);
 175
 176         if ($opt->{tree}) {
 177                 my @values = map {tag_soap_entity($_)} @{$opt->{value}};
 178                 $opt->{value} = \@values;
 179         }
 180         eval {$obj = new SOAP::Data (%$opt);};
 181         if ($@) {
 182                 logError ("soap_entity failed: $@");
 183                 return;
 184         }
 185         return $obj;
 186 }
 187
 188 my %intrinsic = (local => sub {$CGI::remote_addr eq '127.0.0.1'},
 189                                 never => sub {return 0},
 190                                 always => sub {return 1});
 191
 192 sub soap_gate {
 193         my (@args, $status, $subref, $spath);
 194
 195         # check first global control configuration which takes
 196         # precedence, then catalog control configuration
 197         for $subref ($Global::SOAP_Control,
 198                                  $Vend::Cfg->{SOAP_Control}) {
 199                 @args = @_;
 200
 201                 while (@args) {
 202                         $spath = join('/', @args);
 203                         pop(@args);
 204                         next unless exists $subref->{$spath};
 205
 206                         if (ref($subref->{$spath}) eq 'CODE') {
 207                                 $status = $subref->{$spath}->($spath);
 208                         } elsif ($subref->{$spath}) {
 209                                 $status = soap_control_intrinsic($subref->{$spath}, $spath);
 210                         }
 211
 212                         # check found, done with loop
 213                         last;
 214                 }
 215
 216                 last unless $status;
 217         }
 218
 219         die errmsg("Unauthorized access to '%s' method\n", join('/', @_))
 220                 unless $status;
 221
 222         return 1;
 223 }
 224
 225 sub soap_control_intrinsic {
 226         my ($checklist, $action) = @_;
 227         my @checks = split /\s*;\s*/, $checklist;
 228         my $status = 1;
 229
 230         for(@checks) {
 231                 my ($check, @args) = split /:/, $_;
 232                 my $sub = $intrinsic{$check} or return 0;
 233
 234                 unless( $sub->($action, @args) ) {
 235                         $status = 0;
 236                         last;
 237                 }
 238         }
 239         return $status;
 240 }
 241
 242 # This is used to check the session name. If there is some reason
 243 # the session is retired, the returned ID will be different from the
 244 # passed ID and the client can cope.
 245 #
 246 # This variant returns the full SessionName so that multiple hosts
 247 # can use the same ID.
 248 sub session_name {
 249         my $self = shift;
 250         my $class = ref($self) || $self;
 251         my $sid = shift;
 252
 253         if($sid) {
 254 #::logDebug("looking to assign session $sid, sessionID=$Vend::SessionID cookiehost=$CGI::cookiehost");
 255                 $Vend::SessionID = $sid;
 256                 $Vend::SessionID =~ s/:(.*)//
 257                         and $CGI::cookiehost = $1;
 258         }
 259
 260         open_soap_session();
 261         close_soap_session();
 262
 263 #::logDebug("actual session name $Vend::SessionName");
 264         return $Vend::SessionName;
 265 }
 266
 267 # This is used to check the session name. If there is some reason
 268 # the session is retired, the returned ID will be different from the
 269 # passed ID and the client can cope.
 270 #
 271 # This variant returns only the SessionID for better security in single-host
 272 # environments.
 273 sub session_id {
 274         my $self = shift;
 275         my $class = ref($self) || $self;
 276         my $sid = shift;
 277
 278         if($sid) {
 279 #::logDebug("looking to assign session id $sid");
 280                 $Vend::SessionID = $sid;
 281         }
 282
 283         open_soap_session();
 284         close_soap_session();
 285
 286 #::logDebug("actual session name $Vend::SessionID");
 287         return $Vend::SessionID;
 288 }
 289
 290 sub Values {
 291         shift;
 292
 293         soap_gate('Values');
 294         open_soap_session();
 295         my $putref;
 296         my $ref = $::Values ||= {};
 297 #::logDebug("ref from session is " . ::uneval($ref));
 298         if($putref = shift) {
 299                 %{$ref} = %{$putref};
 300         }
 301         close_soap_session();
 302 #::logDebug("ref from session is now " . ::uneval($ref));
 303         return $ref;
 304 }
 305
 306 sub Session {
 307         shift;
 308         open_soap_session();
 309         my $putref;
 310         my $ref = $Vend::Session;
 311         if($putref = shift) {
 312                 if (! ref($ref)) {
 313                         Vend::Session::init_session();
 314                         $ref = $Vend::Session;
 315                 }
 316                 %{$ref} = %{$putref};
 317         }
 318         close_soap_session();
 319         return $ref;
 320 }
 321
 322 sub Scratch {
 323         shift;
 324
 325         soap_gate('Scratch');
 326         open_soap_session();
 327         my $putref;
 328         my $ref = $Vend::Session->{scratch};
 329         if($putref = shift) {
 330                 $ref = $Vend::Session->{scratch} = {}
 331                         if ! ref($ref);
 332                 %{$ref} = %{$putref};
 333         }
 334         close_soap_session();
 335         return $ref;
 336 }
 337
 338 sub Database {
 339         shift;
 340         my $name = shift;
 341
 342         soap_gate('Database', $name);
 343
 344         my $ref = $Vend::Cfg->{Database};
 345         return $ref->{$name} if $name;
 346         return $ref;
 347 }
 348
 349 sub open_soap_session {
 350 #::logDebug("opening session $Vend::SessionID");
 351         ::get_session($Vend::SessionID);
 352 #::logDebug("actual session $Vend::SessionID");
 353         return $Vend::SessionID;
 354 }
 355
 356 sub close_soap_session {
 357 #::logDebug("closing session $Vend::SessionID");
 358         ::put_session();
 359         ::close_session();
 360         undef $Vend::Session;
 361         undef $Vend::SessionOpen;
 362 }
 363
 364 sub AUTOLOAD {
 365     my $routine = $AUTOLOAD;
 366 #::logDebug("SOAP autoload called, routine=$routine, args=" . ::uneval(\@_));
 367         my $class = shift;
 368         my $sub;
 369
 370         if($Tmp::Autoloaded++ > 100) {
 371                 die "must be in endless loop, autoloaded $Tmp::Autoloaded times";
 372         }
 373
 374         chdir $Vend::Cfg->{VendRoot}
 375                 or die "Couldn't change to $Vend::Cfg->{VendRoot}: $!\n";
 376
 377         ::open_database();
 378         open_soap_session();
 379 #::logDebug("SOAP init_session done, session_id=$Vend::SessionID");
 380
 381 #::logDebug("session " . ::full_dump() );
 382
 383     $routine =~ s/.*:://;
 384
 385         if ($Vend::Cfg->{SOAP_Action}{$routine}) {
 386                 soap_gate ('Action', $routine);
 387                 $sub = $Vend::Cfg->{SOAP_Action}{$routine};
 388                 Vend::Interpolate::init_calc();
 389                 new Vend::Tags;
 390                 new Vend::Parse;        # enable catalog usertags within SOAP actions
 391         } elsif (! $Allowed_tags{$routine}) {
 392                 die ::errmsg("Not allowed routine: %s", $routine);
 393         } else {
 394                 soap_gate ('Tag', $routine);
 395         }
 396
 397         my $result;
 398         if (defined $sub) {
 399                 eval {
 400                         $result = $sub->(@_);
 401                 };
 402         } else {
 403 #::logDebug("do_tag $routine, args=" . ::uneval(\@_));
 404                 eval {
 405                         if(ref($_[0])) {
 406 #::logDebug("resolving args");
 407                                 @_ = Vend::Parse::resolve_args($routine, @_);
 408                         }
 409 #::logDebug("do_tag $routine");
 410                         $result = Vend::Parse::do_tag($routine, @_);
 411                 };
 412         }
 413
 414         my $error;
 415         if($@) {
 416                 ::logError("SOAP call for $routine failed: %s", $@);
 417
 418                 $error = SOAP::Server->make_fault($SOAP::Constants::FAULT_SERVER,
 419                                                            'Application error');
 420         }
 421 #::logDebug("session " . ::full_dump() );
 422
 423         close_soap_session();
 424         ::close_database();
 425
 426         die $error if $error;
 427
 428 #::logDebug("session " . ::full_dump() );
 429         return $result;
 430 }
 431
 432 1;
 433 __END__
 434