The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package TestHelper;

use strict;
use warnings;
use base 'Exporter';

use Mojolicious::Lite;
use Mojolicious::Plugin::DigestAuth::Util qw{checksum parse_header};

our @EXPORT = qw{build_auth_request users create_action IE6};

my $users = { sshaw => 'itzme!' };
sub users { $_[0] ? $users->{$_[0]} : $users }
sub IE6 { 'Mozilla/5.0 (compatible; MSIE 6.0; Windows NT 5.1)' }

sub create_action
{
    my $options = { @_ };
    $options->{allow} ||= users();

    my $env = delete $options->{env} || {};
    sub { 
	my $self = shift;
	$self->app->plugin('digest_auth', $options);
	$self->req->env($env);
	$self->render_text("You're in!") if $self->digest_auth;
    };
}

# This fx() should use the same code as DigestAuth!
sub build_auth_request
{
    my ($tx, %defaults) = @_;
    my $req_header = parse_header($tx->res->headers->www_authenticate);	
    my $res_header = {};
    my $user = delete $defaults{username};
    my $pass = delete $defaults{password};
    my @common_parts = qw{algorithm nonce opaque realm};	

    $user = 'sshaw' if !defined $user;
    $pass = users($user) || '' if !defined $pass;

    local $_;
    @$res_header{@common_parts, keys %defaults} = (@$req_header{@common_parts}, values %defaults);

    # Test::Mojo handles the url differently between versions
    # What versions? Is this still necessary, maybe it was pre 1.32?
    if(!defined $res_header->{uri}) {
	$res_header->{uri} = $tx->req->url->path->to_string;
	$res_header->{uri} .= '?' . $tx->req->url->query if $tx->req->url->query->to_string;
    }
    
    $res_header->{nc} ||= 1;
    $res_header->{cnonce} ||= time();
    $res_header->{qop} ||= 'auth';
    $res_header->{username} = $user;
    $res_header->{response} = checksum(checksum($user, $res_header->{realm}, $pass),
				       $res_header->{nonce},
				       $res_header->{nc},
				       $res_header->{cnonce},
				       $res_header->{qop},
				       checksum($tx->req->method, $res_header->{uri}));    

    { Authorization => sprintf('Digest %s', join ', ', map { qq|$_="$res_header->{$_}"| } keys %$res_header) };      
}

1;