D.1 HTTP SOAP Code ( Chapter 7 )
D.1 HTTP SOAP Code (Chapter 7)The code from Chapter 7 is presented in the same order in which it was introduced in the chapter. D.1.1 WishListCustomerThis is the basic container class for the catalog and user classes that are to be presented as a unified interface. Example D-1. WishListCustomer.pm # # The WishListCustomer package is the basis for the SOAP # example in Chapters 7 and 8. It is a container class for # two other interfaces, SoapExBook and SoapExUser. # package WishListCustomer; use strict; use subs qw(new GetBook BooksByAuthor BooksByTitle Wishlist AddBook RemoveBook CanPurchase PurchaseBooks SetUser make_cookie); use Digest::MD5 'md5_hex'; use SoapExBook; use SoapExUser; 1; # # The class constructor # sub new { my ($class, $user, $passwd) = @_; my $self = bless {}, $class; die "$!" unless $self->{_catalog} = SoapExBook::connect; if ($user and $passwd) { return undef unless $self->SetUser(user => $user, password => $passwd); } $self; } # # Initialize and load specific user information into the # main object. # sub SetUser { my ($self, %args) = @_; $self->{_user} = SoapExUser->new( ); unless (ref($self) and $args{user} and $self->{_user}->get_user($args{user})) { undef $self->{_user}; return "Could not load data for $args{user}"; } # User data is loaded beforehand, so that the password # is available for testing. If the validation fails, # user object is destroyed before the error is sent, so # that the caller does not accidentally get the user # data. if ($args{password}) { unless ($args{password} eq $self->{_user}->passwd) { undef $self->{_user}; return "Bad password for $args{user}"; } } elsif ($args{cookie}) { unless ($args{cookie} eq make_cookie($args{user}, $self->{_user}->{passwd})) { undef $self->{_user}; return "Auth token for $args{user} invalid"; } } else { undef $self->{_user}; return "No authentication present for $args{user}"; } $self; } # # Retrieve information on one specific book. May be called # as a static method. # sub GetBook { my ($self, $isbn) = @_; # If this is called as a static method, then get a fresh # book-database connection. Otherwise, use the one that # is already available. my $bookdb = ref($self) ? $self->{_catalog} : SoapExBook::connect( ); return 'Unable to connect to catalog' unless $bookdb; # If there is a valid user record, set the flag to # return extra information my $fullinfo = $self->{_user} ? 1 : 0; my $book = SoapExBook::get_book($bookdb, $isbn); return "No book found for key $isbn" unless $book; return { title => $book->{title}, isbn => $book->{isbn}, url => $book->{url}, $fullinfo ? ( authors => $book->{authors}, us_price => $book->{us_price} ) : ( ) }; } # # Retrieve a list of keys of books whose authors field # contains the requested substring. May be called as a # static method. # sub BooksByAuthor { my ($class, $author) = @_; # If this is called as a static method, then get a fresh # book-database connection. Otherwise, use the one that # is already available. my $bookdb = ref($class) ? $class->{_catalog} : SoapExBook::connect( ); return 'Unable to connect to catalog' unless $bookdb; my @books = SoapExBook::get_books_by_author($bookdb, $author); \@books; } # # Retrieve a list of keys of books whose title field # contains the requested substring. May be called as a # static method. # sub BooksByTitle { my ($class, $title) = @_; # If this is called as a static method, then get a fresh # book-database connection. Otherwise, use the one that # is already available. my $bookdb = ref($class) ? $class->{_catalog} : SoapExBook::connect( ); return 'Unable to connect to catalog' unless $bookdb; my @books = SoapExBook::get_books_by_title($bookdb, $title); \@books; } # # Return the current contents of the user's wish-list. The # list contains abbreviated book information. # sub Wishlist { my $self = shift; # This is not callable as a static method, so it must # have a value user object stored within. return 'The object is missing user data' unless (ref($self) and my $user = $self->{_user}); return 'The object is missing catalog data' unless (my $bdb = $self->{_catalog}); my $books = $user->wishlist; # At this point, @$books is full of keys, not data my ($book, @books); for (@$books) { return "ISBN $_ unknown to catalog" unless ($book = SoapExBook::get_book($bdb, $_)); push(@books, { isbn => $book->{isbn}, title => $book->{title}, url => $book->{url} }); } \@books; } # # Add the specified book to the user's wish-list. Returns an # error if the key/ISBN is unknown to the catalog. # sub AddBook { my ($self, $isbn) = @_; # This is not callable as a static method, so it must # have a value user object stored within. return 'The object is missing user data' unless (my $user = $self->{_user}); return "ISBN $isbn unknown to catalog" unless $user->add_book($isbn); $user->write_user; $self; } # # Remove a specified book from the wish-list. Note that this # does NOT return an error if the book was not on the list. # That case is silently ignored. # sub RemoveBook { my ($self, $isbn) = @_; # This is not callable as a static method, so it must # have a value user object stored within. return 'The object is missing user data' unless (my $user = $self->{_user}); $user->drop_book($isbn); $user->write_user; $self; } # # Return a true/false value indicating whether the user is # approved to purchase books directly off their wish-list. # sub CanPurchase { my $self = shift; # This is not callable as a static method, so it must # have a value user object stored within. return 'Object is missing user data' unless (ref($self) and my $user = $self->{_user}); $user->can_purchase; } # # Attempt to purchase one or more books on the wish-list. # The parameter $list contains either a single key, or a # list-reference of keys. # sub PurchaseBooks { my ($self, $list) = @_; # This is not callable as a static method, so it must # have a value user object stored within. return 'Object is missing user data' unless (ref($self) and my $user = $self->{_user}); return 'User cannot make direct purchases' unless ($user->can_purchase); # Handle a single ISBN as just a one-item list my @books = ref($list) ? @$list : ($list); # Here would normally be lots of convoluted glue code to # interact with enterprise systems, CRM, etc. For this # example, just remove the books from the wishlist and # update the user. $user->drop_book($_) for (@books); $user->write_user; $self; } # # This is the code that is used to generate cookies based on # the user name and password. It is not cryptographically # sound, it is just a simple form of obfuscation, used as an # example. # # Courtesy of the Slash codebase # sub make_cookie { my ($user, $passwd) = @_; my $cookie = $user . '::' . md5_hex($passwd); $cookie =~ s/(.)/sprintf("%%%02x", ord())/ge; $cookie =~ s/%/%25/g; $cookie; } D.1.2 SoapExUserThe first of the two classes encapsulated by WishListCustomer , this example manages the user data as a class, interfacing with a DB_File store. Example D-2. SoapExUser.pm package SoapExUser; use 5.005; use strict; use vars qw($DBNAME); use subs qw(import new get_user write_user name wishlist can_purchase add_book drop_book dbconnect); use DB_File; use Storable qw(freeze thaw); use SoapExBook; sub import { my ($proto, %args) = @_; # Right now, only $args{database} is recognized $DBNAME = $args{database} ''; } sub new { my ($class, @args) = @_; my (%hash, $k, $v); @hash{qw(name passwd wishlist purchase_ok)} = ('', '', [ ], 0); while (@args) { ($k, $v) = splice(@args, 0, 2); $hash{lc $k} = $v; } bless \%hash, $class; } sub get_user { my ($self, $user) = @_; my ($db, $val); $db = dbconnect; return undef if ($db->get($user, $val)); $val = thaw $val; %$self = %$val; $self; } sub write_user { my $self = $_[0]; return undef unless $self->{name}; my $db = dbconnect; # Pass freeze( ) a hashref to a COPY of $self, unblessed return undef if ($db->put($self->{name}, freeze({ %$self }))); $self; } sub name { $_[0]->{name}; } sub passwd { my ($self, $newpass) = @_; $self->{passwd} = $newpass if $newpass; $self->{passwd}; } sub wishlist { my $list = $_[0]->{wishlist}; # Return a listref that is a copy, not the main list $list ? [ @$list ] : [ ]; } sub can_purchase { $_[0]->{purchase_ok}; } sub add_book { my ($self, $book) = @_; my $bookdb = SoapExBook::connect; return undef unless ($bookdb and SoapExBook::get_book($bookdb, $book)); $book =~ s/-//g; push(@{$self->{wishlist}}, $book); $self; } sub drop_book { my ($self, $book) = @_; $book =~ s/-//g; @{$self->{wishlist}} = grep($_ ne $book, @{$self->{wishlist}}); $self; } sub dbconnect { $DBNAME ($DBNAME = _ _FILE_ _) =~ s[^/]+$users.db; my %hash; tie %hash, 'DB_File', $DBNAME; } 1; D.1.3 SoapExBookThe second of the two interfaces encapsulated by WishListCustomer , this manages connections to the book catalog using a DB_File store. Example D-3. SoapExBook.pm package SoapExBook; use 5.005; use strict; use subs qw(connect get_book get_books_by_title get_books_by_author); use DB_File; use Storable qw(freeze thaw); sub connect { my $dbfile = $_[0]; $dbfile ($dbfile = _ _FILE_ _) =~ s[^/]+$catalog.db; my ($tied, %hash); return unless ($tied = tie(%hash, 'DB_File', $dbfile)); $tied; } sub get_book { my ($db, $key) = @_; my $val; $key =~ s/-//g; return undef if $db->get($key, $val); thaw $val; } sub get_books_by_title { my ($db, $pat) = @_; my ($key, $val, @matches); return ( ) if ($db->seq($key, $val, R_FIRST)); do { $val = thaw $val; push(@matches, $key) if (index(lc $val->{title}, lc $pat) != -1); } until ($db->seq($key, $val, R_NEXT)); @matches; } sub get_books_by_author { my ($db, $pat) = @_; my ($key, $val, @matches); return ( ) if ($db->seq($key, $val, R_FIRST)); do { $val = thaw $val; push(@matches, $key) if (index(lc $val->{authors}, lc $pat) != -1); } until ($db->seq($key, $val, R_NEXT)); @matches; } 1; D.1.4 The First HTTP::Daemon ServerThe first of the servers based on SOAP::Transport::HTTP::Daemon provides the most basic linkage between WishListCustomer and SOAP::Lite , with no authentication layer. Example D-4. Server-HTTP::Daemon-1 #!/usr/bin/perl -w # # A simple server that does not yet do access-control on # requests. # use strict; use SOAP::Transport::HTTP; # Loading this class here keeps SOAP::Lite from having to # load it on demand. use WishListCustomer; my $port = pop(@ARGV) 9000; my $host = shift(@ARGV) 'localhost'; SOAP::Transport::HTTP::Daemon ->new(LocalAddr => $host, LocalPort => $port, Reuse => 1) ->dispatch_with({ 'urn:/WishListCustomer' => 'WishListCustomer' }) ->objects_by_reference('WishListCustomer') ->handle; exit; D.1.5 WishListCustomer::DaemonThis subclass of SOAP::Transport::HTTP::Daemon is the first half of the solution that provides user authentication in the SOAP environment. Example D-5. WishListCustomer::Daemon.pm # # The sample daemon class derived by sub-classing the # SOAP::Transport::HTTP::Daemon class, which is in turn # derived from HTTP::Daemon. # package WishListCustomer::Daemon; use strict; use vars qw(@ISA); use SOAP::Transport::HTTP; @ISA = qw(SOAP::Transport::HTTP::Daemon); 1; # # This is the only method that needs to be overloaded in # order for this daemon class to handle the authentication. # All cookie headers on the incoming request get copied to # a hash table local to the WishListCustomer::SOAP # package. The request is then passed on to the original # version of this method. # sub request { my $self = shift; if (my $request = $_[0]) { my @cookies = $request->headers->header('cookie'); %WishListCustomer::SOAP::COOKIES = ( ); for my $line (@cookies) { for (split(/; /, $line)) { next unless /(.*?)=(.*)/; $WishListCustomer::SOAP::COOKIES{} = ; } } } $self->SUPER::request(@_); } D.1.6 WishListCustomer::SOAPThis class provides a SOAP-oriented layer over the basic WishListCustomer class and combines with the previous class to manage user-level authentication via cookies. Example D-6. WishListCustomer::SOAP.pm # # This is the sample SOAP layer built over the # WishListCustomer class, as part of the exercises of # chapters 7 and 8. # package WishListCustomer::SOAP; use strict; use vars qw(@ISA %COOKIES); use SOAP::Lite; use WishListCustomer; @ISA = qw(WishListCustomer); BEGIN { no strict 'refs'; # # This block creates local versions of the methods # in the list. The local versions catch errors that # would otherwise be simple text, and turn them into # SOAP::Fault objects. # for my $method qw(GetBook BooksByAuthor BooksByTitle Wishlist AddBook RemoveBook PurchaseBooks) { eval "sub $method"; *$method = sub { my $self = shift->new; die SOAP::Fault ->faultcode('Server.RequestError') ->faultstring('Could not get object') unless $self; my $smethod = "SUPER::$method"; my $res = $self->$smethod(@_); die SOAP::Fault ->faultcode('Server.ExecError') ->faultstring("Execution error: $res") unless ref($res); $res; }; } } 1; # # The class constructor. It is designed to be called by each # invocation of each other method. As such, it returns the # first argument immediately if it is already an object of # the class. This lets users of the class rely on constructs # such as cookie-based authentication, where each request # calls for a new object instance. # sub new { my $class = shift; return $class if ref($class); my $self; # If there are no arguments, but available cookies, then # that is the signal to work the cookies into play if ((! @_) and (keys %COOKIES)) { # Start by getting the basic, bare object $self = $class->SUPER::new( ); # Then call SetUser. It will die with a SOAP::Fault # on any error $self->SetUser; } else { $self = $class->SUPER::new(@_); } $self; } # # This derived version of SetUser hands off to the parent- # class version if any arguments are passed. If none are, # it looks for cookies to provide the authentication. The # user name is extracted from the cookie, and the "user" # and "cookie" arguments are passed to the parent-class # SetUser method with these values. # sub SetUser { my $self = shift->new; my %args = @_; return $self->SUPER::SetUser(%args) if (%args); my $user; my $cookie = $COOKIES{user}; return $self unless $cookie; ($user = $cookie) =~ s/%([0-9a-f]{2})/chr(hex())/ge; $user =~ s/%([0-9a-f]{2})/chr(hex())/ge; $user =~ s/::.*//; my $res = $self->SUPER::SetUser(user => $user, cookie => $cookie); die SOAP::Fault ->faultcode('Server.AuthError') ->faultstring("Authorization failed: $res") unless ref($res); $self; } # # This method could not be relegated to the loop-construct # in the BEGIN block above, because SOAP::Lite cannot tell # instinctively that this method returns a boolean rather # than an integer. So the value from the parent-class # method is coerced into the correct encoding via the # SOAP::Data class. # sub CanPurchase { my $self = shift->new; die SOAP::Fault->faultcode('Server.RequestError') ->faultstring('Could not get object') unless $self; SOAP::Data->name('return', $self->SUPER::CanPurchase) ->type('xsd:boolean'); } D.1.7 The Second HTTP::Daemon ServerThis is the same server as used initially, only now it uses the two new classes in place of the original ones. Example D-7. server-HTTP::Daemon-2 #!/usr/bin/perl -w # # Version 2 of the daemon, this time using a SOAP layer for # the methods to expose, and a daemon class that derives # from the original HTTP::Daemon-based class for the server # layer. Combined, these allow for basic authentication of # user operations. # use strict; # Again, loading this now saves effort for SOAP::Lite use WishListCustomer::SOAP; use WishListCustomer::Daemon; my $port = pop(@ARGV) 9000; my $host = shift(@ARGV) 'localhost'; WishListCustomer::Daemon ->new(LocalAddr => $host, LocalPort => $port, Reuse => 1) ->dispatch_with({ 'urn:/WishListCustomer' => 'WishListCustomer::SOAP' }) ->objects_by_reference('WishListCustomer::SOAP') ->handle; exit; D.1.8 The SOAP::Lite Client to Format a Wish ListThis client tested the server presented earlier by retrieving the wish list for a specified user and displaying the formatted data to the console. Example D-8. client-wishlist-1#!/usr/bin/perl -w # # This is a sample client that calls the SOAP interface on # the specified endpoint (defaulting to a local address) # gets the wishlist for the specified user. The data is # given a simple formatting by means of a format-picture. # This client needed no updating even as the server was # moved from HTTP::Daemon to Apache/mod_perl. # use strict; use URI; use HTTP::Cookies; use SOAP::Lite; # This is included only to avoid re-copying the cookie # code. use WishListCustomer; # for make_cookie my ($user, $passwd) = (shift, shift); die "USAGE: D.1.9 WishListCustomer::ApacheThis class subclasses the SOAP::Transport::HTTP::Apache class to provide the authentication cookies in the same manner as the previous server class. Example D-9. WishListCustomer::Apache.pm # # The sample Apache-binding layer for the Chapter 7 SOAP # example. # package WishListCustomer::Apache; use strict; use vars qw(@ISA); # # In addition to loading the SOAP::Transport::HTTP module, # The WishListCustomer::SOAP module is loaded here so that # it is available immediately, without SOAP::Lite having # to load it on-demand. # use SOAP::Transport::HTTP; use WishListCustomer::SOAP; @ISA = qw(SOAP::Transport::HTTP::Apache); 1; # # The only routine that needs to be overloaded to use the # existing Apache code is this one. This version looks for # any cookies in the incoming request and stores them in a # hash table local to the WishListCustomer::SOAP module. # It then passes the request on to the original version of # this method. # sub handler ($$) { my ($self, $request) = @_; my $cookies = $request->header_in('cookie'); my @cookies = ref $cookies ? @$cookies : $cookies; %WishListCustomer::SOAP::COOKIES = ( ); for my $line (@cookies) { for (split(/; /, $line)) { next unless /(.*?)=(.*)/; $WishListCustomer::SOAP::COOKIES{} = ; } } $self->SUPER::handler($request); } D.1.10 WishListCustomer::SOAP2The revised interface design in this class replaces the two search functions with a single interface that uses the parameter's name within the SOAP envelope to control the search. Example D-10. WishListCustomer::SOAP2.pm # # This is the sample SOAP layer as presented in the # WishListCustomer::SOAP class, but with the FindBooks # method instead of the BooksByAuthor and BooksByTitle # methods. Hence, it cannot inherit from that class # without exposing them. Only the changes parts of the # code are documented. # package WishListCustomer::SOAP2; use strict; use vars qw(@ISA %COOKIES); use SOAP::Lite; use WishListCustomer; # # Adding SOAP::Server::Parameters to the inheritance # tree enables the FindBooks method to access the # deserialized request object. # @ISA = qw(WishListCustomer SOAP::Server::Parameters); BEGIN { no strict 'refs'; # # Note the absence of BooksByAuthor and BooksByTitle # from this list. # for my $method qw(GetBook Wishlist AddBook RemoveBook PurchaseBooks) { eval "sub $method"; *$method = sub { my $self = shift->new; die SOAP::Fault ->faultcode('Server.RequestError') ->faultstring('Could not get object') unless $self; my $smethod = "SUPER::$method"; my $res = $self->$smethod(@_); die SOAP::Fault ->faultcode('Server.ExecError') ->faultstring("Execution error: $res") unless ref($res); $res; }; } } 1; sub new { my $class = shift; return $class if ref($class); my $self; # If there are no arguments, but available cookies, then # that is the signal to work the cookies into play if ((! @_) and (keys %COOKIES)) { # Start by getting the basic, bare object $self = $class->SUPER::new( ); # Then call SetUser. It will die with a SOAP::Fault # on any error $self->SetUser; } else { $self = $class->SUPER::new(@_); } $self; } sub SetUser { my $self = shift->new; my %args = @_; return $self->SUPER::SetUser(%args) if (%args); my $user; my $cookie = $COOKIES{user}; return $self unless $cookie; ($user = $cookie) =~ s/%([0-9a-f]{2})/chr(hex())/ge; $user =~ s/%([0-9a-f]{2})/chr(hex())/ge; $user =~ s/::.*//; my $res = $self->SUPER::SetUser(user => $user, cookie => $cookie); die SOAP::Fault ->faultcode('Server.AuthError') ->faultstring("Authorization failed: $res") unless ref($res); $self; } # # This replaces BooksBy{Author,Title} with a single # interface that uses the name given to the input parameter # to choose the type of search to execute. # sub FindBooks { my ($class, $arg, $env) = @_; # # Using the SOAP envelope of the request, get the # SOAP::Data object that wraps the value $arg was # assigned. # my $argname = $env->match(SOAP::SOM::paramsin)->dataof; my $hook = ($argname->name eq 'author') ? \&SoapExBook::get_books_by_author : \&SoapExBook::get_books_by_title; # # As with the originals, this can be a static method, # so the test to use a new book-database handle versus # the self-stored one is still present. # my $bookdb = ref($class) ? $class->{_catalog} : SoapExBook::connect( ); return 'Unable to connect to catalog' unless $bookdb; my @books = $hook->($bookdb, $arg); \@books; } sub CanPurchase { my $self = shift->new; die SOAP::Fault->faultcode('Server.RequestError') ->faultstring('Could not get object') unless $self; SOAP::Data->name('return', $self->SUPER::CanPurchase) ->type('xsd:boolean'); } D.1.11 The Third HTTP::Daemon ServerThe final version of the HTTP::Daemon -based server differs from the previous only in that it uses the revised SOAP interface presented in the previous section. Example D-11. server-HTTP::Daemon-3 #!/usr/bin/perl -w # # The third version of the HTTP::Daemon-based server uses # the SOAP layer with the FindBooks method in place of the # two original search methods. Note that this will not # correctly handle the authentication because of the # coupling between the WishListCustomer::Daemon and the # WishListCustomer::SOAP classes. # use strict; use WishListCustomer::SOAP2; use WishListCustomer::Daemon; my $port = pop(@ARGV) 9000; my $host = shift(@ARGV) 'localhost'; WishListCustomer::Daemon ->new(LocalAddr => $host, LocalPort => $port, Reuse => 1) ->dispatch_with({ 'urn:/WishListCustomer' => 'WishListCustomer::SOAP2' }) ->objects_by_reference('WishListCustomer::SOAP2') ->handle; exit; D.1.12 The SOAP::Lite Client to Test FindBooksThis client is a simplified version of the first client, designed to test the FindBooks method defined in the revised SOAP interface. Example D-12. client-wishlist-2#!/usr/bin/perl -w # # This sample client is much simpler than the previous one, # as it is only intended to demonstrate the flexibility of # having the single-entry search interface that uses the # parameter name to help in forming the search. # use strict; use SOAP::Lite; my ($type, $string) = (shift, shift); die "USAGE: |
Programming Web Services with Perl
ISBN: 0596002068
EAN: 2147483647
EAN: 2147483647
Year: 2000
Pages: 123
Pages: 123
Authors: Randy J. Ray, Pavel Kulchenko