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

 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";
 }

 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";
 }

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

  http://github.com/mannih/cpan

#  Copyright (c) 2008-2009 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: 2009-11-06
#   Revision: 43
#

package Google::SAML::Request;

use strict;
use warnings;

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


our $VERSION = '0.04';

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;
}

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;
}

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;
    }
}

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";
    }
}

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;
}

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

1;