package Authen::NZRealMe::AuthenRequest;
$Authen::NZRealMe::AuthenRequest::VERSION = '1.20';
use strict;
use warnings;

require XML::Generator;

use MIME::Base64               qw(encode_base64 decode_base64);
use URI::Escape                qw(uri_escape uri_unescape);
use IO::Uncompress::RawInflate qw(rawinflate $RawInflateError);
use IO::Compress::RawDeflate   qw(rawdeflate $RawDeflateError);

use Authen::NZRealMe::CommonURIs qw(NS_PAIR);
use Authen::NZRealMe::Asserts    qw(assert_is_base64);

my $ns_saml  = [ NS_PAIR('saml') ];
my $ns_samlp = [ NS_PAIR('samlp') ];


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

    my $self = bless {
        allow_create    => 'false',
        auth_strength   => 'low',
        acs_index       => 0,
        @_,
    }, $class;
    return $self->_init($sp);
}


sub _init {
    my($self, $sp) = @_;

    $self->{service_type}    = $sp->type;
    $self->{request_id}      = $sp->generate_saml_id('AuthnRequest');
    $self->{entity_id}       = $sp->entity_id;
    $self->{destination_url} = $sp->idp->single_signon_location;
    $self->{request_time}    = $sp->now_as_iso();
    $self->{nameid_format}   = $sp->nameid_format();

    my $strength_class       = Authen::NZRealMe->class_for('logon_strength');
    $self->{auth_strength}   = $strength_class->new($self->{auth_strength});

    my $xml = $self->_generate_authn_request_doc();
    $self->{query_string} = $sp->sign_query_string($self->_raw_query_string);

    return $self;
}


sub service_type    { shift->{service_type};        }
sub request_id      { shift->{request_id};          }
sub entity_id       { shift->{entity_id};           }
sub request_time    { shift->{request_time};        }
sub destination_url { shift->{destination_url};     }
sub saml_request    { shift->{saml_request};        }
sub relay_state     { shift->{relay_state};         }
sub acs_index       { shift->{acs_index};           }
sub allow_create    { shift->_bool('allow_create'); }
sub auth_strength   { shift->{auth_strength};       }
sub _query_string   { shift->{query_string};        }
sub _nameid_format  { shift->{nameid_format};       }
sub _x              { shift->{x};                   }


sub _bool {
    my($self, $flag) = @_;
    my $value = shift->{$flag};
    return (defined($value) && lc($value) =~ /^(1|true)$/)
           ? 'true'
           : 'false';
}


sub as_url {
    my $self = shift;

    return $self->destination_url . '?' . $self->_query_string;
}


sub _raw_query_string {
    my $self = shift;

    my $qs = 'SAMLRequest=' . uri_escape( $self->encoded_saml_request() );

    if(my $rs = $self->relay_state) {
        $qs .= '&RelayState=' . uri_escape($rs);
    }

    return $qs;
}


sub _generate_authn_request_doc {
    my $self = shift;

    my $x = XML::Generator->new(#':pretty',
        namespace => [ @$ns_saml, @$ns_samlp ],
    );
    $self->{x} = $x;

    $self->{saml_request} = $x->AuthnRequest($ns_samlp,
        {
            Version                       => '2.0',
            ID                            => $self->request_id(),
            IssueInstant                  => $self->request_time(),
            Destination                   => $self->destination_url(),
            AssertionConsumerServiceIndex => $self->acs_index(),
        },
        $self->_issuer(),
        $self->_nameid_policy(),
        $self->service_type eq 'login'
            ? $self->_authen_context()
            : (),
    ) . '';  # ensure result is stringified
}


sub _issuer {
    my $self = shift;
    my $x    = $self->_x;

    return $x->Issuer($ns_saml,
        $self->entity_id
    );
}


sub _nameid_policy {
    my $self = shift;

    return $self->_login_nameid_policy()     if $self->service_type eq 'login';
    return $self->_assertion_nameid_policy() if $self->service_type eq 'assertion';
}


sub _login_nameid_policy {
    my $self = shift;
    my $x    = $self->_x;

    return $x->NameIDPolicy($ns_samlp,
        {
            Format      => $self->_nameid_format(),
            AllowCreate => $self->allow_create(),
        },
    );
}


sub _assertion_nameid_policy {
    my $self = shift;
    my $x    = $self->_x;

    return $x->NameIDPolicy($ns_samlp,
        {
            Format      => $self->_nameid_format(),
        },
    );
}


sub _authen_context {
    my $self = shift;
    my $x    = $self->_x;

    my $strength = $self->auth_strength();
    return $x->RequestedAuthnContext($ns_samlp,
        $x->AuthnContextClassRef($ns_saml, $strength->urn()),
    );
}


sub encoded_saml_request {
    my($self) = @_;

    my $xml    = $self->saml_request();
    my $data   = '';
    my $status = rawdeflate \$xml => \$data, Append => 0
        or die "Can't compress request data: $RawDeflateError\n";

    $data = encode_base64($data);
    $data =~ s{[\r\n]}{}g;

    return $data;
}


sub dump_request {
    my $class = shift;

    # Get data from commandline or slurp from standard input

    my $data = @_
               ? shift
               : do { local($/) = undef; <STDIN>; };

    my $xml  = $data =~ m{^https?:}
               ? $class->_request_from_uri($data)
               : $class->_request_from_uri_param($data);

    print $xml, "\n";
}


sub _request_from_uri {
    my($class, $uri) = @_;

    my($data) = $uri =~ m{\bSAMLRequest=(.*?)(?:&|$)}
        or die "Can't find 'SAMLRequest' parameter in query string";
    return  $class->_request_from_uri_param($data);
}


sub _request_from_uri_param {
    my($class, $data) = @_;

    $data = uri_unescape($data);

    assert_is_base64($data, 'SAMLRequest');
    $data = decode_base64($data);

    my($xml, $status);
    $status = rawinflate \$data => \$xml
        or die "Can't decompress request data: $RawInflateError\n";

    return $xml;
}

1;

__END__

=head1 NAME

Authen::NZRealMe::AuthenRequest - Generate a SAML2 AuthenRequest message

=head1 DESCRIPTION

This package is used by the L<Authen::NZRealMe::ServiceProvider> to generate a
SAML2 AuthnRequest message and send it to the NZ RealMe Login service IdP
(Identity Provider) using the HTTP-Redirect binding.

=head1 METHODS

=head2 new

Constructor.  Should not be called directly.  Instead, call the C<new_request>
method on the service provider object.

The following named parameters are recognised:

  allow_create     boolean       (default: false)
  relay_state      short string  (default: none)
  auth_strength    see below     (default: 'low')

=head2 service_type

Accessor for the type of service ("login" or "assertion") this request is
intended for.

=head2 request_id

Accessor for the generated unique ID for this request.

=head2 entity_id

Accessor for the entity ID of the Service Provider which generated the request.

=head2 request_time

Accessor for the request creation time formatted as an ISO date/time string.

=head2 destination_url

Accessor for the URL of the Identity Provider's single signon service, to which
this request will be sent.

=head2 saml_request

Accessor for the XML document containing the SAML2 AuthenRequest.

=head2 acs_index

Accessor for the C<acs_index> parameter optionally passed to the constructor.
If not provided, a default ACS index of 0 will be used.

=head2 relay_state

Accessor for the C<relay_state> parameter optionally passed to the constructor.
If not provided, no relay state will be passed to the Identity Provider.

=head2 allow_create

Accessor for the C<allow_create> parameter optionally passed to the constructor.
If not provided, this parameter will default to 'false'.

=head2 auth_strength

Accessor for the C<auth_strength> parameter optionally passed to the
constructor.  If a value is provided, it will be passed to the constructor for
L<Authen::NZRealMe::LogonStrength>.  If not provided, this parameter will
default to the URN for low strength logons.

=head2 as_url

Accessor for the URL to be used in the redirect.  The URL will be constructed
from the URL of the Identity Provider's single signon service and a query
string containing the SAML2 AuthnRequest message an optional relay state
parameter and a digital signature.

=head2 encoded_saml_request

Accessor for the XML SAML AuthnRequest message after deflate compression and
MIME Base64 encoding have been applied.

=head2 dump_request

This method is used by the C<< nzrealme dump-req >> command to decode and
decompress the SAMLRequest parameter from a generated URL.  It is provided as a
diagnostic aid.


=head1 SEE ALSO

See L<Authen::NZRealMe> for documentation index.


=head1 LICENSE AND COPYRIGHT

Copyright (c) 2010-2019 Enrolment Services, New Zealand Electoral Commission

Written by Grant McLean E<lt>grant@catalyst.net.nzE<gt>

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.

=cut


