#  Copyright (c) 2008 Manni Heumann. All rights reserved.
#
#  This program is free software; you can redistribute it and/or
#  modify it under the same terms as Perl itself.
#
#   Date: $Date: 2008-06-05 14:23:14 +0200 (Thu, 05 Jun 2008) $
#   Revision: $Revision: 37 $
#

package Google::SAML::Request;

=head1 NAME

Google::SAML::Request - Create or parse Google's SAML requests

=head1 VERSION

You are currently reading the documentation for version 0.01

=head1 DESCRIPTION

Google::SAML::Request will parse (and, for the sake of completeness, create)
SAML requests as used by Google. B<Please note> that Google::SAML::Request is by
no means a full implementation of the SAML 2.0 standard. But if you want to
talk to Google to authenticate users, you should be fine.

In fact, if you want to talk to Google about SSO, just use
L<Google::SAML::Response|Google::SAML::Response>
and you should be fine.

=head1 SYNOPSIS

Create a new request object by taking the request ouf of the CGI environment:

 use Google::SAML::Request;
 my $req = Google::SAML::Request->new_from_cgi();
 if ( $req->ProviderName() eq 'google.com'
    && $req->AssertionConsumerServiceURL() eq 'https://www.google.com/hosted/psosamldemo.net/acs' ) {

    processRequest();
 }
 else {
     print "go talk to someone else\n";
 }

Or use a request string that you get from somewhere else (but make sure that it is no longer
URI-escaped):

 use Google::SAML::Request;
 my $req = Google::SAML::Request->new_from_string( $request_string );
 if ( $req->ProviderName() eq 'google.com'
    && $req->AssertionConsumerServiceURL() eq 'https://www.google.com/hosted/psosamldemo.net/acs' ) {

    processRequest();
 }
 else {
     print "go talk to someone else\n";
 }

Or, finally, create a request from scratch and send that to somebody else:

 use Google::SAML::Request;
 my $req = Google::SAML::Request->new(
            {
                ProviderName => 'me.but.invalid',
                AssertionConsumerServiceURL => 'http://send.your.users.here.invalid/script',
            }
           );




=head1 PREREQUISITES

You will need the following modules installed:

=over

=item * L<MIME::Base64|MIME::Base64>

=item * L<Compress::Zlib|Compress::Zlib>

=item * L<Date::Format|Date::Format>

=item * L<XML::Simple|XML::Simple>

=item * L<URI::Escape|URI::Escape>

=item * L<CGI|CGI> (if you are going to use the 'new_from_cgi' constructor)

=back

=head1 METHODS

=cut

use strict;
use warnings;

use MIME::Base64;
use Compress::Zlib;
use Date::Format;
use Carp;
use XML::Simple;
use URI::Escape;


our $VERSION = '0.02';


=head2 new

Create a new Google::SAML::Request object from scratch.

You have to provide the needed parameters here. Some parameters
are optional and defaults are used if they are not supplied.

The parameters need to be passed in in a hash reference as
key value pairs.

=head3 Required parameters

=over

=item * ProviderName

Your name, e.g. 'google.com'

=item * AssertionConsumerServiceURL

The URL the user used to contact you. E.g. 'https://www.google.com/hosted/psosamldemo.net/acs'

=back

=head3 Optional parameters

=over

=item * IssueInstant

The time stamp for the Request. Default is I<now>.

=item * ID

If you need to create the ID yourself, use this option. Otherwise the ID is
generated from the current time and a pseudo-random number.

=back

=cut

sub new {
    my $class = shift;
    my $args  = shift;

    my $self = {
        ProviderName
            => '',
        AssertionConsumerServiceURL
            => '',
        IssueInstant
            => time2str( "%Y-%m-%dT%XZ", time, 'UTC' ),
        ID
            => undef,
    };

    bless $self, $class;

    foreach my $required ( qw/ ProviderName AssertionConsumerServiceURL / ) {
        confess "You need to provide the $required parameter to Googe::SAML::Request::new()"
            unless exists $args->{ $required };
        $self->{ $required } = $args->{ $required };
    }

    foreach my $optional ( qw/ IssueInstant ID / ) {
        $self->{ $optional } = $args->{ $optional }
            if exists $args->{ $optional };
    }

    unless ( defined $self->{ ID } ) {
        $self->{ ID } = $self->_generate_id();
    }

    $self->{request} = {
          'ID'                          => $self->{ID},
          'Version'                     => '2.0',
          'xmlns:samlp'                 => 'urn:oasis:names:tc:SAML:2.0:protocol',
          'IssueInstant'                => $self->{IssueInstant},
          'ProviderName'                => $self->{ProviderName},
          'ProtocolBinding'             => 'urn:oasis:names.tc:SAML:2.0:bindings:HTTP-Redirect',
          'AssertionConsumerServiceURL' => $self->{AssertionConsumerServiceURL},
    };

    return $self;
}




=head2 new_from_cgi

Create a new Google::SAML::Request object by fishing it out of the CGI
environment.

If you provide a hash-ref with the key 'param_name' you can determine
which cgi parameter to use. The default is 'SAMLRequest'.

=cut

sub new_from_cgi {
    my $class = shift;
    my $args  = shift;

    my $self ={};
    bless $self, $class;

    require CGI;
    my $cgi = CGI->new();

    my $param = ( exists $args->{param_name} ) ? $args->{param_name} : 'SAMLRequest';
    my $request = $cgi->param( $param );

    if ( ! $request ) {
        warn "could not get request from cgi environment through parameter '$param'.";
    }
    elsif ( $self->_decode_saml_msg( $request ) ) {
        return $self;
    }

    return;
}






=head2 new_from_string

Pass in a (uri_unescaped!) string that contains the request string. The string
will be base64-unencoded, inflated and parsed. You'll get back a fresh
Google::SAML::Response object if the string can be parsed.

=cut

sub new_from_string {
    my $class  = shift;
    my $string = shift;

    my $self = {};
    bless $self, $class;

    if ( $self->_decode_saml_msg( $string ) ) {
        return $self;
    }
    else {
        return;
    }
}



=head2 get_xml

Returns the XML representation of the request.

=cut

sub get_xml {
    my $self = shift;

    if ( exists $self->{request} ) {
        return
            XMLout( $self->{request},
                    KeyAttr  => [ keys %{$self->{request}} ],
                    RootName => 'samlp:AuthnRequest',
                    XMLDecl  => 1
            );
    }
    else {
        confess "The request object hasn't even been made yet";
    }
}


=head2 get_get_param

No, that's not a typo. This method will return the request in a form
suitable to be used as a GET parameter. In other words, this method
will take the XML representation, compress it, base64-encode the result
and, finally, URI-escape that.

=cut

sub get_get_param {
    my $self = shift;

    my $xml = $self->get_xml();

    my ( $d, $status ) = deflateInit( -WindowBits => -&MAX_WBITS() );

    if ( $status == Z_OK && $d ) {
        my ( $compressed, $status ) = $d->deflate( $xml );
        $compressed .= $d->flush();

        if ( $status == Z_OK && length( $compressed ) ) {
            my $encoded = encode_base64( $compressed, '' );
            my $escaped = uri_escape( $encoded );

            return $escaped;
        }
        else {
            warn "Could not compress xml";
        }
    }
    else {
        warn "Could not initialise deflation stream.";
    }

    return;
}





sub _generate_id {
    my $self = shift;

    my $id = '';

    my $time = time;
    foreach ( split //, $time ) {
        $id .= chr( $_ + 97 );
    }

    foreach ( 1 .. 30 ) {
        $id .= chr( int(rand( 26 )) + 97 );
    }

    return $id;
}




sub _decode_saml_msg {
    my $self = shift;
	my $msg  = shift;

	my $decoded  = decode_base64( $msg );
    my $inflated = undef;

    foreach my $wbits ( -&MAX_WBITS(), &MAX_WBITS() ) {
        $inflated = $self->_inflate( $decoded, $wbits );
        last if defined $inflated;
    }

    if ( defined $inflated ) {
        $self->{request} = XMLin( $inflated, ForceArray => 0 );
        foreach ( qw/ ProviderName AssertionConsumerServiceURL ID IssueInstant / ) {
            $self->{ $_ } = $self->{request}->{ $_ };
        }

        return 1;
    }
    else {
        warn "Could not inflate base64-decoded string.";
    }

	return;
}




sub _inflate {
    my $self       = shift;
    my $string     = shift;
    my $windowBits = shift;

    my ( $i, $status ) = inflateInit( -WindowBits => $windowBits );

	if ( $status == Z_OK ) {
		my $inflated;
		($inflated, $status) = $i->inflate( $string );

		if ( $status == Z_OK || $status == Z_STREAM_END ) {
		    return $inflated;
		}
	}
	else {
	    warn "No inflater!";
	}

	return;
}



=head3 Accessor methods (read-only)

All of the following accessor methods return the value of the
attribute with the same name

=head2 AssertionConsumerServiceURL

=head2 ID

=head2 IssueInstant

=head2 ProtocolBinding

=head2 ProviderName

=head2 Version

=cut

sub AssertionConsumerServiceURL { return shift->{AssertionConsumerServiceURL}; }
sub ID { return shift->{ID}; }
sub IssueInstant { return shift->{IssueInstant}; }
sub ProviderName { return shift->{ProviderName}; }

=head1 AUTHOR

Manni Heumann (saml at lxxi dot org)


=head1 LICENSE

Copyright (c) 2008 Manni Heumann. All rights reserved.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

=cut


1;