source: aai/shib_test/shib_test.pl @ 5723

#!/usr/bin/env perl
#
# Version: $Id: shib_test.pl 5723 2014-10-16 09:29:47Z schonefeld@ids-mannheim.de $
#
use strict;
use warnings;
use CGI;
use CGI::Carp qw( fatalsToBrowser);
use URI;

#
# constants
#
my @ATTRIBUTES_REQUIRED = qw(
    eduPersonPrincipalName:eppn
    eduPersonTargetedID:persistent_id
);
my @ATTRIBUTES_OPTIONAL = qw(
    eduPersonScopedAffiliation:affiliation:eduPersonAffiliation
    cn
    displayName
);


# allow override from environment ...
if (exists $ENV{'SHIBTEST_ATTRIBUTES_REQUIRED'}) {
    @ATTRIBUTES_REQUIRED = split('\s+', $ENV{'SHIBTEST_ATTRIBUTES_REQUIRED'});
}
if (exists $ENV{'SHIBTEST_ATTRIBUTES_OPTIONAL'}) {
    @ATTRIBUTES_OPTIONAL = split('\s+', $ENV{'SHIBTEST_ATTRIBUTES_OPTIONAL'});
}


#
# code below ... nothing to change there ...
#
sub xml_escape {
    my $s = shift;

    $s =~ s!&!&!gs;
    $s =~ s!<!&lt;!gs;
    $s =~ s!>!&gt;!gs;
    return $s;
}


sub render_table_rows {
    my $caption = shift;
    my $keys    = shift;
    my $i = 0;
    print '<tr class="header">', '<th colspan="2">',
        $caption, '</th>', '</tr>';
    if (scalar(@{$keys}) > 0) {
        foreach my $key (@{$keys}) {
            my $value = $ENV{$key};
            $value =~ s!\n*!!gs;
            $value =~ s!\s*(;|\$)\s*!\n!gs;
            $value = xml_escape($value);
            $value =~ s!\n!<br />!gs;
            print '<tr class="', ($i++ % 2 == 0 ? 'even' : 'odd'), '">';
            print '<td>', $key, '</td>', '<td>', $value, '</td>', '</tr>';
        }
    }
    else {
        print '<tr class="even"><td colspan="2">',
            '<span class="error center">[NONE]</span></tr>';
    }
}


sub dump_shibboleth_attributes {
    my $debug_env = shift;
    
    my @keys = sort(keys(%ENV));
    my @attrs = grep(!m/^(HTTPS|SERVER_|SCRIPT_|PATH|QUERY_STRING|GATEWAY|DOCUMENT_ROOT|REMOTE|REQUEST|HTTP_|AUTH_TYPE|Shib_)/i, @keys);
    my @shib = grep(m/Shib_/i, @keys);

    render_table_rows('Shibboleth Attributes:', \@attrs);
    render_table_rows('Shibboleth Enviroment Variables:', \@shib);
    if (defined ($debug_env)) {
        render_table_rows('All Environment Variables:', \@keys);
    }
}


sub dump_shibboleth_assertions {
    my $count = shift;

    return unless defined($count) && $count > 0;

    # try to load LWP and XML::Twig and bail if not available ...
    eval {
        require LWP;
        require XML::Twig;
    };
    if ($@) {
        return;
    }
    print '<tr class="header">', '<th colspan="2">',
        'Raw SAML Assertion(s)', '</th>', '</tr>';
    my $j = 0;
    my $browser = LWP::UserAgent->new;
    ASSERTION:
    for (my $i = 1; $i <= $count; $i++) {
        my $url = $ENV{sprintf('Shib_Assertion_%02d', $i)};
        next ASSERTION unless defined ($url);

        print '<tr class="', ($j++ % 2 == 0 ? 'even' : 'odd'), '">';
        print '<td>Assertion ', $i, '</td>';
        my $response = $browser->get($url);
        if ($response->is_success) {
            my $twig = XML::Twig->new(pretty_print => 'indented',
                                      output_encoding => 'utf-8',
                                      no_prolog => '1',
                                      keep_original_prefix => '1');
            $twig->parse($response->content);
            my $s = $twig->sprint();
            $s = xml_escape($s);
            $s =~ s! !&nbsp;!gs;
            $s =~ s!\n!<br />!gs;
            print '<td>', $s, '</td>';
        }
        else {
            print '<td>', '<span class="error">Cannot retieve assertion: ',
            xml_escape($response->status_line), '</span>', '</td>';
        }
        print '</tr>';
    }
}


sub make_self_uri {
    my $scheme = exists $ENV{'HTTPS'} ? 'https' : 'http';
    my $uri = URI->new($scheme . '://' . $ENV{'SERVER_NAME'});
    $uri->path($ENV{'REQUEST_URI'});
    return $uri->as_string();
}


sub make_shibboleth_uri {
    my $path = shift;

    # XXX: always assume https for Shibboleth URIs ...
    my $uri = URI->new('https://' . $ENV{'SERVER_NAME'});
    $uri->path($path);
    return $uri;
}


sub make_login_uri {
    my $uri = $ENV{'SHIBTEST_LOGIN_URI'};
    if (defined($uri)) {
        $uri = URI->new($uri);
    }
    else {
        $uri = make_shibboleth_uri('/Shibboleth.sso/Login');
    }
    $uri->query_form({
        target => make_self_uri(),
    });
    return $uri->as_string();
}


sub make_logout_uri {
    my $uri = $ENV{'SHIBTEST_LOGOUT_URI'};
    if (defined($uri)) {
        $uri = URI->new($uri);
    }
    else {
        $uri = make_shibboleth_uri('/Shibboleth.sso/Logout');
    }
    $uri->query_form({
        return => make_self_uri(),
    });
    return $uri->as_string();
}


sub scan_attributes {
    my $scan_ref    = shift;
    my $optional    = shift;
    my $missing     = 0;

    foreach my $aliases (@{$scan_ref}) {
        my $found = undef;
        my @attrs = split(':', $aliases);

        KEY:
        foreach my $b (keys(%ENV)) {
            foreach my $a (@attrs) {
                if (lc($a) eq lc($b)) {
                    $found = $b;
                    last KEY;
                }
            }
        }

        if (defined($found)) {
            print '<p class="attr ok">',
                ($optional ? 'Optional'
                           : 'Required'),
                ' attribute <code>', $attrs[0], '</code> is available',
                ($found ne $attrs[0] ? " (exported as <code>$found</code>)"
                                     : ''),
                '.</p>';
        }
        else {
            print '', ($optional ? '<p class="attr warn">Optional'
                                 : '<p class="attr error">Required'),
                ' attribute <code>', $attrs[0],
                '</code> is not available.</p>';
            $missing++;
        }
    }
    return $missing;
}


sub main {
    my $q = shift;

    if (defined($ENV{'Shib_Session_ID'})) {
        # logout link
        my $idp = $ENV{'Shib_Identity_Provider'};
        if (!defined($idp)) {
            $idp = '<span class="error">[UNKNOWN]</span>';
        }
        print '<p>';
        print 'A Shibboleth session was established with <em>', $idp,
            '</em>.';
        if (defined($ENV{'SHIBTEST_LAZY'})) {
            print ' [<a href="', make_logout_uri(), '">Logout</a>]<br />';
            print 'NB: if this webserver is configured to always requires ',
                'authentication for this page, you will be immediately ',
                'redirected to the WAYF/Discovery service after logging out!';
        }
        print '</p>';

        my $errors   = 0;
        my $warnings = 0;
        # CLARIN required attributes
        if (scalar(@ATTRIBUTES_REQUIRED) > 0) {
            $errors += scan_attributes(\@ATTRIBUTES_REQUIRED, 0);
        }

        # CLARIN optional attributes
        if (scalar(@ATTRIBUTES_OPTIONAL) > 0) {
            $warnings += scan_attributes(\@ATTRIBUTES_OPTIONAL, 1);
        }

        # remote user
        my $user = $ENV{'REMOTE_USER'};
        $warnings++ unless defined($user);
        print '<p class="attr ', (defined($user) ? 'ok' : 'warn'), '">';
        print 'REMOTE_USER: ',
            (defined($user) ? $user : 'N/A (not exported by mod_shib?!)');
        print '</p>';

        if ($errors == 0) {
            print '<p class="ok result">Interoperability between your SP ',
                'and the IDP is ',
                ($warnings > 0 ? 'sufficent' : 'optimal'), '. ',
                $errors, ' error(s), ',
                $warnings, ' warning(s)</p>';
        }
        else {
            print '<p class="error result">Interoperability between your SP ',
                'and the IDP is problematic! ', $errors, ' error(s), ',
                $warnings, ' warning(s) <br/>',
                'Please check SP config and IDP release policy.</p>';
        }
        # attribute / environment variable / assertion
        print '<table class="attr">';
        my $debug_env = (defined($q) && $q->param('debug_env'));
        dump_shibboleth_attributes($debug_env);
        dump_shibboleth_assertions($ENV{'Shib_Assertion_Count'});
        print '</table>';
    }
    else {
        # login link
        print '<p>No Shibboleth session exists, please <a href="',
            make_login_uri(), '">Login</a>.</p>';
    }
}


my $style = <<STYLE;
body {
    font-family: Arial, Verdana, sans-serif;
    font-size: 12pt;
    margin: 0;
    padding: 2px;
}

h1 {
    font-size: 150%;
    margin: 0 0 5px 0;
    padding: 0;
}

h2 {
    font-size: 100%;
    margin: 1px 0;
    padding: 0;
}

p {
    margin: 10px 0;
    padding: 4px;
}

p.ok {
    color: #FFFFFF;
    background-color: #009900;
}


p.warn {
    color: #000000;
    background-color: #FFFF00;
}

p.error {
    color: #FFFFFF;
    background-color: #CC0000;
    font-weight: bold;
}

p.attr {
    margin: 1px 0;
}

p.result {
    margin: 20px 0;
    font-size: 120%;
    font-weight: bold;
    border: 2px solid #000000;
}

code {
    font-family: "Courier New", monospace;
    font-weight: bold;
}

span.error {
    color: #CC0000;
    background-color: inherit;
    font-weight: bold;
}

table {
    border: 1px solid #000000;
    border-collapse: collapse;
    margin: 0;
    padding: 0;
}

td, th {
    border: 1px solid #000000;
    vertical-align: top;
    text-align: left;
    margin: 0;
    padding: 4px;
}

th {
    font-weight: bold;
    font-size: 110%;
    color: #FFFFFF;
    background-color: transparent;
}

.header {
    color: inherit;
    background-color: #707677;
}

.even {
    color: inherit;
    background-color: #E7E7E7;
}

.odd {
    color: inherit;
    background-color: #CFCFCF;
}
STYLE

my $q = CGI->new();
print $q->header(-type => 'text/html', -charset => 'utf-8');
print $q->start_html(-title => 'CLARIN SPF Interoperability Test Page',
                     -style => { -code => $style });
print $q->h1('CLARIN SPF Interoperability Test Page');
main($q);
print $q->end_html;
exit 0;