Google::SAML::Response - Generate signed XML documents as SAML responses for

 use Google::SAML::Response;
 use CGI;

 # get SAMLRequest parameter:
 my $req = CGI->new()->param('SAMLRequest');

 # authenticate user
 ...

 # find our user's login for Google
 ...

 # Generate SAML response
 my $saml = Google::SAML::Response->new( { 
                            key     => $key, 
                            login   => $login, 
                            request => $req 
            } );
 my $xml  = $saml->get_response_xml();

 # Alternatively, send a HTML page to the client that will redirect
 # her to Google. You have to extract the RelayState param from the cgi
 # environment first.

 print $saml->get_google_form( $relayState );

 xmlsec1 --verify --store-references --store-signatures test.xml > debug.txt

  http://github.com/mannih/cpan

#  Copyright (c) 2010 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.
#

package Google::SAML::Response;

use strict;
use warnings;

use Crypt::OpenSSL::RSA;
use MIME::Base64;
use Digest::SHA qw/ sha1 /;
use Date::Format;
use Compress::Zlib;
use Google::SAML::Request;
use Carp;


our $VERSION = '0.10';

sub new {
    my $class = shift;

    my $params = shift;
    my $self = {};

    foreach my $required ( qw/ request key login / ) {
        if ( exists $params->{ $required } ) {
            $self->{ $required } = $params->{ $required };
        }
        else {
            confess "You need to provide the $required parameter!";
        }
    }

    bless $self, $class;

    my $request = Google::SAML::Request->new_from_string( $self->{request} );

    if ( $request && $self->_load_key() ) {
        $self->{ service_url }   = $request->AssertionConsumerServiceURL();
        $self->{ request_id }    = $request->ID();
        $self->{ ttl }           = ( exists $params->{ ttl } ) ? $params->{ ttl } : 60*2;
        $self->{ canonicalizer } = exists $params->{ canonicalizer } 
                                    ? $params->{ canonicalizer } 
                                    : 'XML::CanonicalizeXML';

        return $self;
    }
    else {
        return;
    }

}


sub _load_dsa_key {
    my $self = shift;
    my $key_text = shift;

    eval {
        require Crypt::OpenSSL::DSA;
    };

    confess "Crypt::OpenSSL::DSA needs to be installed so that we can handle DSA keys." if $@;

    my $dsa_key = Crypt::OpenSSL::DSA->read_priv_key_str( $key_text );

    if ( $dsa_key ) {
        $self->{ key_obj } = $dsa_key;
        my $g = encode_base64( $dsa_key->get_g(), '' );
        my $p = encode_base64( $dsa_key->get_p(), '' );
        my $q = encode_base64( $dsa_key->get_q(), '' );
        my $y = encode_base64( $dsa_key->get_pub_key(), '' );

        $self->{KeyInfo} = "<KeyInfo><KeyValue><DSAKeyValue><P>$p</P><Q>$q</Q><G>$g</G><Y>$y</Y></DSAKeyValue></KeyValue></KeyInfo>";
        $self->{key_type} = 'dsa';
    }
    else {
        confess "did not get a new Crypt::OpenSSL::RSA object";
    }
}


sub _load_rsa_key {
    my $self = shift;
    my $key_text = shift;

    my $rsaKey = Crypt::OpenSSL::RSA->new_private_key( $key_text );

    if ( $rsaKey ) {
        $rsaKey->use_pkcs1_padding();
        $self->{ key_obj } = $rsaKey;

        my $bigNum = ( $rsaKey->get_key_parameters() )[1];
        my $bin = $bigNum->to_bin();
        my $exp = encode_base64( $bin, '' );

        $bigNum = ( $rsaKey->get_key_parameters() )[0];
        $bin = $bigNum->to_bin();
        my $mod = encode_base64( $bin, '' );
        $self->{KeyInfo} = "<KeyInfo><KeyValue><RSAKeyValue><Modulus>$mod</Modulus><Exponent>$exp</Exponent></RSAKeyValue></KeyValue></KeyInfo>";
        $self->{key_type} = 'rsa';
    }
    else {
        confess "did not get a new Crypt::OpenSSL::RSA object";
    }
}


sub _load_key {
    my $self = shift;
    my $file = $self->{ key };

    if ( open my $KEY, '<', $file ) {
        my $text = '';
        local $/ = undef;
        $text = <$KEY>;
        close $KEY;

        if ( $text =~ m/BEGIN ([DR]SA) PRIVATE KEY/ ) {
            my $key_used = $1;

            if ( $key_used eq 'RSA' ) {
                $self->_load_rsa_key( $text );
            }
            else {
                $self->_load_dsa_key( $text );
            }

            return 1;
        }
        else {
            confess "Could not detect type of key $file.";
        }
    }
    else {
        confess "Could not load key $file: $!";
    }

    return;
}

sub get_response_xml {
    my $self = shift;

    # This is the xml response without any signatures or digests:
    my $xml           = $self->_response_xml();

    # We now calculate the SHA1 digest of the canoncial response xml
    my $canonical     = $self->_canonicalize_xml( $xml );

    my $bin_digest    = sha1( $canonical );
    my $digest        = encode_base64( $bin_digest, '' );

    # Create a xml fragment containing the digest:
    my $digest_xml    = $self->_reference_xml( $digest );

    # create a xml fragment consisting of the SignedInfo element
    my $signed_info   = $self->_signedinfo_xml( $digest_xml );

    # We now calculate a signature over the canonical SignedInfo element

    $canonical        = $self->_canonicalize_xml( $signed_info );
    my $signature;

    if ( $self->{ key_type } eq 'dsa' ) {
        my $sig = $self->{ key_obj }->do_sign( sha1( $canonical ) );
        $signature = encode_base64( $sig->get_r . $sig->get_s );
    }
    else {
        my $bin_signature = $self->{key_obj}->sign( $canonical );
        $signature = encode_base64( $bin_signature, "\n" );
    }

    # With the signature value and the signedinfo element, we create
    # a Signature element:
    my $signature_xml = $self->_signature_xml( $signed_info, $signature );

    # Now insert the signature xml into our response xml
    $xml =~ s/<samlp:Status>/$signature_xml<samlp:Status>/;

    return "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n" . $xml;
}


sub _signature_xml {
    my $self = shift;
    my $signed_info = shift;
    my $signature_value = shift;

    return qq{<Signature xmlns="http://www.w3.org/2000/09/xmldsig#">
                        $signed_info
                        <SignatureValue>$signature_value</SignatureValue>
                        $self->{KeyInfo}
                </Signature>};
}


sub _signedinfo_xml {
    my $self = shift;
    my $digest_xml = shift;

    return qq{<SignedInfo xmlns="http://www.w3.org/2000/09/xmldsig#" xmlns:samlp="urn:oasis:names:tc:SAML:2.0:protocol" xmlns:xenc="http://www.w3.org/2001/04/xmlenc#">
                                <CanonicalizationMethod Algorithm="http://www.w3.org/TR/2001/REC-xml-c14n-20010315#WithComments" />
                                <SignatureMethod Algorithm="http://www.w3.org/2000/09/xmldsig#$self->{key_type}-sha1" />
                                $digest_xml
                        </SignedInfo>};
}


sub _reference_xml {
    my $self = shift;
    my $digest = shift;

    return qq{<Reference URI="">
                                                <Transforms>
                                                        <Transform Algorithm="http://www.w3.org/2000/09/xmldsig#enveloped-signature" />
                                                </Transforms>
                                                <DigestMethod Algorithm="http://www.w3.org/2000/09/xmldsig#sha1" />
                                                <DigestValue>$digest</DigestValue>
                                        </Reference>};
}


sub _canonicalize_xml {
    my $self = shift;
    my $xml  = shift;

    if ( $self->{canonicalizer} eq 'XML::Canonical' ) {
        require XML::Canonical;
        my $xmlcanon = XML::Canonical->new( comments => 1 );
        return $xmlcanon->canonicalize_string( $xml );
    }
    elsif ( $self->{ canonicalizer } eq 'XML::CanonicalizeXML' ) {
        require XML::CanonicalizeXML;
        my $xpath = '<XPath>(//. | //@* | //namespace::*)</XPath>';
        return XML::CanonicalizeXML::canonicalize( $xml, $xpath, [], 0, 0 );
    }
    else {
        confess "Unknown XML canonicalizer module.";
    }
}


sub _response_xml {
    my $self = shift;

    # A 160-bit string containing a set of randomly generated characters.
    # The ID MUST start with a character
    my $response_id   = sprintf 'GOSAML0d%04d', time, rand(10000);

    # A timestamp indicating the date and time that the SAML response was generated
    # Bsp: 2006-08-17T10:05:29Z
    # All SAML time values have the type xs:dateTime, which is built in to the W3C XML Schema Datatypes
    # specification [Schema2], and MUST be expressed in UTC form, with no time zone component.
    my $issue_instant = time2str( "%Y-%m-%dT%XZ", time, 'UTC' );

    # A 160-bit string containing a set of randomly generated characters.
    my $assertion_id  = sprintf 'GOSAML%010d%04d', time, rand(10000);

    # The acs url
    my $assertion_url = $self->{service_url};

    # The username for the authenticated user.
    my $username      = $self->{login};

    # A timestamp identifying the date and time after which the SAML response is deemed invalid.
    my $best_before   = time2str( "%Y-%m-%dT%XZ", time + $self->{ttl}, 'UTC' );

    # A timestamp indicating the date and time that you authenticated the user.
    my $authn_instant = $issue_instant;

    my $request_id    = $self->{ request_id };

    return
        qq{<samlp:Response xmlns="urn:oasis:names:tc:SAML:2.0:assertion" xmlns:samlp="urn:oasis:names:tc:SAML:2.0:protocol" xmlns:xenc="http://www.w3.org/2001/04/xmlenc#" ID="$response_id" IssueInstant="$issue_instant" Version="2.0">
                <samlp:Status>
                      <samlp:StatusCode Value="urn:oasis:names:tc:SAML:2.0:status:Success"></samlp:StatusCode>
                </samlp:Status>
                <Assertion ID="$assertion_id" IssueInstant="$issue_instant" Version="2.0">
                      <Issuer>https://www.opensaml.org/IDP</Issuer>
                      <Subject>
                            <NameID Format="urn:oasis:names:tc:SAML:1.1:nameid-format:emailAddress">$username</NameID>
                            <SubjectConfirmation Method="urn:oasis:names:tc:SAML:2.0:cm:bearer">
                                  <SubjectConfirmationData
                                        Recipient="$assertion_url"
                                        NotOnOrAfter="$best_before"
                                        InResponseTo="$request_id"
                                  />
                            </SubjectConfirmation>
                      </Subject>
                      <Conditions NotBefore="$issue_instant" NotOnOrAfter="$best_before">
                          <AudienceRestriction>
                              <Audience>$assertion_url</Audience>
                          </AudienceRestriction>
                      </Conditions>
                      <AuthnStatement AuthnInstant="$authn_instant">
                            <AuthnContext>
                                  <AuthnContextClassRef>urn:oasis:names:tc:SAML:2.0:ac:classes:Password</AuthnContextClassRef>
                            </AuthnContext>
                      </AuthnStatement>
                </Assertion>
        </samlp:Response>
};
}

sub get_google_form {
    my $self = shift;
    my $rs   = shift;

    my $url  = $self->{service_url};

    my $output = "Content-type: text/html\n\n";
    $output .= "<html><head></head><body onload='javascript:document.acsForm.submit()'>\n";

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

    $output .= qq|
                <div style="display: none;">
                <form name="acsForm" action="$url" method="post">
                        <textarea name="SAMLResponse">$xml</textarea>
                        <textarea name="RelayState">$rs</textarea>
                        <input type="submit" value="Submit SAML Response" />
                </form>
                </div>
        |;

    $output .= "</body></html>\n";

    return $output;
}

1;