local-lib5/lib/perl5/XML/Atom/Server.pm

   1 # $Id$
   2
   3 package XML::Atom::Server;
   4 use strict;
   5
   6 use XML::Atom;
   7 use base qw( XML::Atom::ErrorHandler );
   8 use MIME::Base64 qw( encode_base64 decode_base64 );
   9 use Digest::SHA1 qw( sha1 );
  10 use XML::Atom::Util qw( first encode_xml textValue );
  11 use XML::Atom::Entry;
  12
  13 use constant NS_SOAP => 'http://schemas.xmlsoap.org/soap/envelope/';
  14 use constant NS_WSSE => 'http://schemas.xmlsoap.org/ws/2002/07/secext';
  15 use constant NS_WSU => 'http://schemas.xmlsoap.org/ws/2002/07/utility';
  16
  17 sub handler ($$) {
  18     my $class = shift;
  19     my($r) = @_;
  20     require Apache::Constants;
  21     if (lc($r->dir_config('Filter') || '') eq 'on') {
  22         $r = $r->filter_register;
  23     }
  24     my $server = $class->new or die $class->errstr;
  25     $server->{apache} = $r;
  26     $server->run;
  27     return Apache::Constants::OK();
  28 }
  29
  30 sub new {
  31     my $class = shift;
  32     my $server = bless { }, $class;
  33     $server->init(@_) or return $class->error($server->errstr);
  34     $server;
  35 }
  36
  37 sub init {
  38     my $server = shift;
  39     $server->{param} = {};
  40     unless ($ENV{MOD_PERL}) {
  41         require CGI;
  42         $server->{cgi} = CGI->new({});
  43     }
  44     $server;
  45 }
  46
  47 sub run {
  48     my $server = shift;
  49     (my $pi = $server->path_info) =~ s!^/!!;
  50     my @args = split /\//, $pi;
  51     for my $arg (@args) {
  52         my($k, $v) = split /=/, $arg, 2;
  53         $server->request_param($k, $v);
  54     }
  55     if (my $action = $server->request_header('SOAPAction')) {
  56         $server->{is_soap} = 1;
  57         $action =~ s/"//g;
  58         my($method) = $action =~ m!/([^/]+)$!;
  59         $server->request_method($method);
  60     }
  61     my $out;
  62     eval {
  63         defined($out = $server->handle_request) or die $server->errstr;
  64         if (defined $out && $server->{is_soap}) {
  65             $out =~ s!^(<\?xml.*?\?>)!!;
  66             $out = <<SOAP;
  67 $1
  68 <soap:Envelope xmlns:soap="http://schemas.xmlsoap.org/soap/envelope/">
  69   <soap:Body>$out</soap:Body>
  70 </soap:Envelope>
  71 SOAP
  72         }
  73     };
  74     if ($@) {
  75         $out = $server->show_error($@);
  76     }
  77     $server->send_http_header;
  78     $server->print($out);
  79     1;
  80 }
  81
  82 sub handle_request;
  83 sub password_for_user;
  84
  85 sub uri {
  86     my $server = shift;
  87     $ENV{MOD_PERL} ? $server->{apache}->uri : $server->{cgi}->url;
  88 }
  89
  90 sub path_info {
  91     my $server = shift;
  92     return $server->{__path_info} if exists $server->{__path_info};
  93     my $path_info;
  94     if ($ENV{MOD_PERL}) {
  95         ## mod_perl often leaves part of the script name (Location)
  96         ## in the path info, for some reason. This should remove it.
  97         $path_info = $server->{apache}->path_info;
  98         if ($path_info) {
  99             my($script_last) = $server->{apache}->location =~ m!/([^/]+)$!;
 100             $path_info =~ s!^/$script_last!!;
 101         }
 102     } else {
 103         $path_info = $server->{cgi}->path_info;
 104     }
 105     $server->{__path_info} = $path_info;
 106 }
 107
 108 sub request_header {
 109     my $server = shift;
 110     my($key) = @_;
 111     if ($ENV{MOD_PERL}) {
 112         return $server->{apache}->header_in($key);
 113     } else {
 114         ($key = uc($key)) =~ tr/-/_/;
 115         return $ENV{'HTTP_' . $key};
 116     }
 117 }
 118
 119 sub request_method {
 120     my $server = shift;
 121     if (@_) {
 122         $server->{request_method} = shift;
 123     } elsif (!exists $server->{request_method}) {
 124         $server->{request_method} =
 125             $ENV{MOD_PERL} ? $server->{apache}->method : $ENV{REQUEST_METHOD};
 126     }
 127     $server->{request_method};
 128 }
 129
 130 sub request_content {
 131     my $server = shift;
 132     unless (exists $server->{request_content}) {
 133         if ($ENV{MOD_PERL}) {
 134             ## Read from $server->{apache}
 135             my $r = $server->{apache};
 136             my $len = $server->request_header('Content-length');
 137             $r->read($server->{request_content}, $len);
 138         } else {
 139             ## Read from STDIN
 140             my $len = $ENV{CONTENT_LENGTH} || 0;
 141             read STDIN, $server->{request_content}, $len;
 142         }
 143     }
 144     $server->{request_content};
 145 }
 146
 147 sub request_param {
 148     my $server = shift;
 149     my $k = shift;
 150     $server->{param}{$k} = shift if @_;
 151     $server->{param}{$k};
 152 }
 153
 154 sub response_header {
 155     my $server = shift;
 156     my($key, $val) = @_;
 157     if ($ENV{MOD_PERL}) {
 158         $server->{apache}->header_out($key, $val);
 159     } else {
 160         unless ($key =~ /^-/) {
 161             ($key = lc($key)) =~ tr/-/_/;
 162             $key = '-' . $key;
 163         }
 164         $server->{cgi_headers}{$key} = $val;
 165     }
 166 }
 167
 168 sub response_code {
 169     my $server = shift;
 170     $server->{response_code} = shift if @_;
 171     $server->{response_code};
 172 }
 173
 174 sub response_content_type {
 175     my $server = shift;
 176     $server->{response_content_type} = shift if @_;
 177     $server->{response_content_type};
 178 }
 179
 180 sub send_http_header {
 181     my $server = shift;
 182     my $type = $server->response_content_type || 'application/x.atom+xml';
 183     if ($ENV{MOD_PERL}) {
 184         $server->{apache}->status($server->response_code || 200);
 185         $server->{apache}->send_http_header($type);
 186     } else {
 187         $server->{cgi_headers}{-status} = $server->response_code || 200;
 188         $server->{cgi_headers}{-type} = $type;
 189         print $server->{cgi}->header(%{ $server->{cgi_headers} });
 190     }
 191 }
 192
 193 sub print {
 194     my $server = shift;
 195     if ($ENV{MOD_PERL}) {
 196         $server->{apache}->print(@_);
 197     } else {
 198         CORE::print(@_);
 199     }
 200 }
 201
 202 sub error {
 203     my $server = shift;
 204     my($code, $msg) = @_;
 205     $server->response_code($code) if ref($server);
 206     return $server->SUPER::error($msg);
 207 }
 208
 209 sub show_error {
 210     my $server = shift;
 211     my($err) = @_;
 212     chomp($err = encode_xml($err));
 213     if ($server->{is_soap}) {
 214         my $code = $server->response_code;
 215         if ($code >= 400) {
 216             $server->response_code(500);
 217         }
 218         return <<FAULT;
 219 <soap:Envelope xmlns:soap="http://schemas.xmlsoap.org/soap/envelope/">
 220   <soap:Body>
 221     <soap:Fault>
 222       <faultcode>$code</faultcode>
 223       <faultstring>$err</faultstring>
 224     </soap:Fault>
 225   </soap:Body>
 226 </soap:Envelope>
 227 FAULT
 228     } else {
 229         return <<ERR;
 230 <?xml version="1.0" encoding="utf-8"?>
 231 <error>$err</error>
 232 ERR
 233     }
 234 }
 235
 236 sub get_auth_info {
 237     my $server = shift;
 238     my %param;
 239     if ($server->{is_soap}) {
 240         my $xml = $server->xml_body;
 241         my $auth = first($xml, NS_WSSE, 'UsernameToken');
 242         $param{Username} = textValue($auth, NS_WSSE, 'Username');
 243         $param{PasswordDigest} = textValue($auth, NS_WSSE, 'Password');
 244         $param{Nonce} = textValue($auth, NS_WSSE, 'Nonce');
 245         $param{Created} = textValue($auth, NS_WSSE, 'Created');
 246     } else {
 247         my $req = $server->request_header('X-WSSE')
 248             or return $server->auth_failure(401, 'X-WSSE authentication required');
 249         $req =~ s/^(?:WSSE|UsernameToken) //;
 250         for my $i (split /,\s*/, $req) {
 251             my($k, $v) = split /=/, $i, 2;
 252             $v =~ s/^"//;
 253             $v =~ s/"$//;
 254             $param{$k} = $v;
 255         }
 256     }
 257     \%param;
 258 }
 259
 260 sub authenticate {
 261     my $server = shift;
 262     my $auth = $server->get_auth_info or return;
 263     for my $f (qw( Username PasswordDigest Nonce Created )) {
 264         return $server->auth_failure(400, "X-WSSE requires $f")
 265             unless $auth->{$f};
 266     }
 267     my $password = $server->password_for_user($auth->{Username});
 268     defined($password) or return $server->auth_failure(403, 'Invalid login');
 269     my $expected = encode_base64(sha1(
 270            decode_base64($auth->{Nonce}) . $auth->{Created} . $password
 271     ), '');
 272     return $server->auth_failure(403, 'Invalid login')
 273         unless $expected eq $auth->{PasswordDigest};
 274     return 1;
 275 }
 276
 277 sub auth_failure {
 278     my $server = shift;
 279     $server->response_header('WWW-Authenticate', 'WSSE profile="UsernameToken"');
 280     return $server->error(@_);
 281 }
 282
 283 sub xml_body {
 284     my $server = shift;
 285     unless (exists $server->{xml_body}) {
 286         if (LIBXML) {
 287             my $parser = XML::LibXML->new;
 288             $server->{xml_body} =
 289                 $parser->parse_string($server->request_content);
 290         } else {
 291             $server->{xml_body} =
 292                 XML::XPath->new(xml => $server->request_content);
 293         }
 294     }
 295     $server->{xml_body};
 296 }
 297
 298 sub atom_body {
 299     my $server = shift;
 300     my $atom;
 301     if ($server->{is_soap}) {
 302         my $xml = $server->xml_body;
 303         $atom = XML::Atom::Entry->new(Doc => first($xml, NS_SOAP, 'Body'))
 304             or return $server->error(500, XML::Atom::Entry->errstr);
 305     } else {
 306         $atom = XML::Atom::Entry->new(Stream => \$server->request_content)
 307             or return $server->error(500, XML::Atom::Entry->errstr);
 308     }
 309     $atom;
 310 }
 311
 312 1;
 313 __END__
 314
 315 =head1 NAME
 316
 317 XML::Atom::Server - A server for the Atom API
 318
 319 =head1 SYNOPSIS
 320
 321     package My::Server;
 322     use base qw( XML::Atom::Server );
 323     sub handle_request {
 324         my $server = shift;
 325         $server->authenticate or return;
 326         my $method = $server->request_method;
 327         if ($method eq 'POST') {
 328             return $server->new_post;
 329         }
 330         ...
 331     }
 332
 333     my %Passwords;
 334     sub password_for_user {
 335         my $server = shift;
 336         my($username) = @_;
 337         $Passwords{$username};
 338     }
 339
 340     sub new_post {
 341         my $server = shift;
 342         my $entry = $server->atom_body or return;
 343         ## $entry is an XML::Atom::Entry object.
 344         ## ... Save the new entry ...
 345     }
 346
 347     package main;
 348     my $server = My::Server->new;
 349     $server->run;
 350
 351 =head1 DESCRIPTION
 352
 353 I<XML::Atom::Server> provides a base class for Atom API servers. It handles
 354 all core server processing, both the SOAP and REST formats of the protocol,
 355 and WSSE authentication. It can also run as either a mod_perl handler or as
 356 part of a CGI program.
 357
 358 It does not provide functions specific to any particular implementation,
 359 such as posting an entry, retrieving a list of entries, deleting an entry, etc.
 360 Implementations should subclass I<XML::Atom::Server>, overriding the
 361 I<handle_request> method, and handle all functions such as this themselves.
 362
 363 =head1 SUBCLASSING
 364
 365 =head2 Request Handling
 366
 367 Subclasses of I<XML::Atom::Server> must override the I<handle_request>
 368 method to perform all request processing. The implementation must set all
 369 response headers, including the response code and any relevant HTTP headers,
 370 and should return a scalar representing the response body to be sent back
 371 to the client.
 372
 373 For example:
 374
 375     sub handle_request {
 376         my $server = shift;
 377         my $method = $server->request_method;
 378         if ($method eq 'POST') {
 379             return $server->new_post;
 380         }
 381         ## ... handle GET, PUT, etc
 382     }
 383
 384     sub new_post {
 385         my $server = shift;
 386         my $entry = $server->atom_body or return;
 387         my $id = save_this_entry($entry);  ## Implementation-specific
 388         $server->response_header(Location => $server->uri . '/entry_id=' . $id);
 389         $server->response_code(201);
 390         $server->response_content_type('application/x.atom+xml');
 391         return serialize_entry($entry);    ## Implementation-specific
 392     }
 393
 394 =head2 Authentication
 395
 396 Servers that require authentication for posting or retrieving entries or
 397 feeds should override the I<password_for_user> method. Given a username
 398 (from the WSSE header), I<password_for_user> should return that user's
 399 password in plaintext. This will then be combined with the nonce and the
 400 creation time to generate the digest, which will be compared with the
 401 digest sent in the WSSE header. If the supplied username doesn't exist in
 402 your user database or alike, just return C<undef>.
 403
 404 For example:
 405
 406     my %Passwords = ( foo => 'bar' );   ## The password for "foo" is "bar".
 407     sub password_for_user {
 408         my $server = shift;
 409         my($username) = @_;
 410         $Passwords{$username};
 411     }
 412
 413 =head1 METHODS
 414
 415 I<XML::Atom::Server> provides a variety of methods to be used by subclasses
 416 for retrieving headers, content, and other request information, and for
 417 setting the same on the response.
 418
 419 =head2 Client Request Parameters
 420
 421 =over 4
 422
 423 =item * $server->uri
 424
 425 Returns the URI of the Atom server implementation.
 426
 427 =item * $server->request_method
 428
 429 Returns the name of the request method sent to the server from the client
 430 (for example, C<GET>, C<POST>, etc). Note that if the client sent the
 431 request in a SOAP envelope, the method is obtained from the I<SOAPAction>
 432 HTTP header.
 433
 434 =item * $server->request_header($header)
 435
 436 Retrieves the value of the HTTP request header I<$header>.
 437
 438 =item * $server->request_content
 439
 440 Returns a scalar containing the contents of a POST or PUT request from the
 441 client.
 442
 443 =item * $server->request_param($param)
 444
 445 I<XML::Atom::Server> automatically parses the PATH_INFO sent in the request
 446 and breaks it up into key-value pairs. This can be used to pass parameters.
 447 For example, in the URI
 448
 449     http://localhost/atom-server/entry_id=1
 450
 451 the I<entry_id> parameter would be set to C<1>.
 452
 453 I<request_param> returns the value of the value of the parameter I<$param>.
 454
 455 =back
 456
 457 =head2 Setting up the Response
 458
 459 =over 4
 460
 461 =item * $server->response_header($header, $value)
 462
 463 Sets the value of the HTTP response header I<$header> to I<$value>.
 464
 465 =item * $server->response_code([ $code ])
 466
 467 Returns the current response code to be sent back to the client, and if
 468 I<$code> is given, sets the response code.
 469
 470 =item * $server->response_content_type([ $type ])
 471
 472 Returns the current I<Content-Type> header to be sent back to the client, and
 473 I<$type> is given, sets the value for that header.
 474
 475 =back
 476
 477 =head2 Processing the Request
 478
 479 =over 4
 480
 481 =item * $server->authenticate
 482
 483 Attempts to authenticate the request based on the authentication
 484 information present in the request (currently just WSSE). This will call
 485 the I<password_for_user> method in the subclass to obtain the cleartext
 486 password for the username given in the request.
 487
 488 =item * $server->atom_body
 489
 490 Returns an I<XML::Atom::Entry> object containing the entry sent in the
 491 request.
 492
 493 =back
 494
 495 =head1 USAGE
 496
 497 Once you have defined your server subclass, you can set it up either as a
 498 CGI program or as a mod_perl handler.
 499
 500 A simple CGI program would look something like this:
 501
 502     #!/usr/bin/perl -w
 503     use strict;
 504
 505     use My::Server;
 506     my $server = My::Server->new;
 507     $server->run;
 508
 509 A simple mod_perl handler configuration would look something like this:
 510
 511     PerlModule My::Server
 512     <Location /atom-server>
 513         SetHandler perl-script
 514         PerlHandler My::Server
 515     </Location>
 516
 517 =head1 ERROR HANDLING
 518
 519 If you wish to return an error from I<handle_request>, you can use the
 520 built-in I<error> method:
 521
 522     sub handle_request {
 523         my $server = shift;
 524         ...
 525         return $server->error(500, "Something went wrong");
 526     }
 527
 528 This will be returned to the client with a response code of 500 and an
 529 error string of C<Something went wrong>. Errors are automatically
 530 serialized into SOAP faults if the incoming request is enclosed in a SOAP
 531 envelope.
 532
 533 =head1 AUTHOR & COPYRIGHT
 534
 535 Please see the I<XML::Atom> manpage for author, copyright, and license
 536 information.
 537
 538 =cut