File Coverage

blib/lib/Mojolicious/Plugin/DigestAuth/RequestHandler.pm

Criterion	Covered	Total	%
statement	149	155	96.1
branch	58	66	87.8
condition	37	61	60.6
subroutine	30	30	100.0
pod	0	2	0.0
total	274	314	87.2

package Mojolicious::Plugin::DigestAuth::RequestHandler;

use strict;
use warnings;

use Carp 'croak';
use Scalar::Util 'weaken';

use Mojo::Util qw{quote b64_encode b64_decode};
use Mojolicious::Plugin::DigestAuth::Util qw{checksum parse_header};

my $QOP_AUTH = 'auth';
my $QOP_AUTH_INT = 'auth-int';
my %VALID_QOPS = ($QOP_AUTH => 1); #, $QOP_AUTH_INT => 1);

my $ALGORITHM_MD5 = 'MD5';
my $ALGORITHM_MD5_SESS = 'MD5-sess';
my %VALID_ALGORITHMS = ($ALGORITHM_MD5 => 1, $ALGORITHM_MD5_SESS => 1);

sub new
{
    my ($class, $config) = @_;
    my $header = {
        qop       => $config->{qop},
        realm     => $config->{realm}     || '',
        domain    => $config->{domain}    || '/',
        algorithm => $config->{algorithm} || $ALGORITHM_MD5,
    };

    # No qop = ''
    $header->{qop} = $QOP_AUTH unless defined $header->{qop}; # "$QOP_AUTH,$QOP_AUTH_INT"
    $header->{opaque} = checksum($header->{domain}, $config->{secret});

    my $self = {
        qops           => {},
        opaque         => $header->{opaque},
        secret         => $config->{secret},
        expires        => $config->{expires},
        algorithm      => $header->{algorithm},
        password_db    => $config->{password_db},
        default_header => $header,
        support_broken_browsers => $config->{support_broken_browsers}
    };

    $self->{support_broken_browsers} = 1 unless defined $self->{support_broken_browsers};

    for my $qop (split /\s*,\s*/, $header->{qop}) {
        croak "unsupported qop: $qop" unless $VALID_QOPS{$qop};
        $self->{qops}->{$qop} = 1;
    }

    croak "unsupported algorithm: $self->{algorithm}" unless $VALID_ALGORITHMS{$self->{algorithm}};
    croak "algorithm $ALGORITHM_MD5_SESS requires a qop" if $self->{algorithm} eq $ALGORITHM_MD5_SESS and ! %{$self->{qops}};

    bless $self, $class;
}

sub _request
{
    (shift)->_controller->req;
}

sub _response
{
    (shift)->_controller->res;
}

sub _controller
{
    (shift)->{controller};
}

sub _nonce_expired
{
    my ($self, $nonce) = @_;
    my $t;

    $t = ($self->_parse_nonce($nonce))[0];
    $t && (time() - int($t)) > $self->{expires};
}

sub _parse_nonce
{
    my ($self, $nonce) = @_;
    split ' ', b64_decode($nonce), 2;
}

sub _valid_nonce
{
    my ($self, $nonce) = @_;
    my ($t, $sig) = $self->_parse_nonce($nonce);

    $t && $sig && $sig eq checksum($t, $self->{secret});
}

sub _create_nonce
{
    my $self  = shift;
    my $t     = time();
    my $nonce = b64_encode(sprintf('%s %s', $t, checksum($t, $self->{secret})));
    chomp $nonce;
    $nonce;
}

sub authenticate
{
    my $self = shift;

    $self->{controller} = shift;
    weaken $self->{controller};

    $self->{response_header} = { %{$self->{default_header}} };

    my $auth = $self->_auth_header;
    if($auth) {
        my $header = parse_header($auth);
        if(!$self->_valid_header($header)) {
            $self->_bad_request;
            return;
        }

        if($self->_authorized($header)) {
            return 1 unless $self->_nonce_expired($header->{nonce});
            $self->{response_header}->{stale} = 'true';
        }
    }

    $self->_unauthorized;
    return;
}

# TODO: $self->_request->headers->proxy_authorization
sub _auth_header
{
  my $self = shift;
  $self->_request->headers->authorization or
  $self->_request->env->{'X_HTTP_AUTHORIZATION'} # Mojo does s/-/_/g
}

sub _unauthorized
{
    my $self = shift;
    my $header = $self->_build_auth_header;

    $self->_response->headers->www_authenticate($header);
    $self->_response->headers->content_type('text/plain');
    $self->_response->code(401);
    $self->_controller->render(text => 'HTTP 401: Unauthorized');
}

sub _bad_request
{
    my $self = shift;
    $self->_response->code(400);
    $self->_response->headers->content_type('text/plain');
    $self->_controller->render(text => 'HTTP 400: Bad Request');
}

sub _valid_header
{
    my ($self, $header) = @_;

    $self->_header_complete($header) &&
    $self->_url_matches($header->{uri}) &&
    $self->_valid_qop($header->{qop}, $header->{nc}) &&
    $self->_valid_opaque($header->{opaque}) &&
    $self->{algorithm} eq $header->{algorithm};
}

sub _url_matches
{
    my $self = shift;

    my $auth_url = shift;
    return unless $auth_url;
    $auth_url = _normalize_url($auth_url);

    my $req_url = $self->_url;

    if($self->_support_broken_browser) {
      # IE 5/6 do not append the querystring on GET requests
      my $i = index($req_url, '?');
      if($self->_request->method eq 'GET' && $i != -1 && index($auth_url, '?') == -1) {
          $auth_url .= '?' . substr($req_url, $i+1);
      }
    }

    $auth_url eq $req_url;
}

#
# We try to avoid using the URL provided by Mojo because:
#
# * Depending on the app's config it will not contain the URL requested by the client
#   it will contain PATH_INFO + QUERY_STRING i.e. /mojo.pl/users/sshaw?x=y will be /users/sshaw?x=y
#
# * Mojo::URL has/had several bugs and has undergone several changes that have broken backwards
#   compatibility.
#
sub _url
{
  my $self = shift;
  my $env = $self->_request->env;
  my $url;

  if($env->{REQUEST_URI}) {
    $url = $env->{REQUEST_URI};
  }
  elsif($env->{SCRIPT_NAME}) {
    $url = $env->{SCRIPT_NAME};
    $url .= $env->{PATH_INFO} if $env->{PATH_INFO};
    $url .= "?$env->{QUERY_STRING}" if $env->{QUERY_STRING};
  }
  elsif($self->_request->url) {
    $url = $self->_request->url->to_string;
  }
  else {
    $url = '/';
  }

  _normalize_url($url);
}

# We want the URL to be relative to '/'
sub _normalize_url
{
  my $s = shift;
  $s =~ s|^https?://[^/?#]*||i;
  $s =~ s|/{2,}|/|g;

  my $url = Mojo::URL->new($s);
  my @parts = @{$url->path->parts};
  my @normalized;

  for my $part (@parts) {
    if($part eq '..' && @normalized) {
      pop @normalized;
      next;
    }

    push @normalized, $part;
  }

  $url->path->parts(\@normalized);
  $url->path->leading_slash(0);
  $url->to_string;
}

# TODO (maybe): IE 6 sends a new nonce every time when using MD5-sess
sub _support_broken_browser
{
    my $self = shift;
    $self->{support_broken_browsers} && $self->_request->headers->user_agent =~ m|\bMSIE\s+[56]\.|;
}

sub _valid_qop
{
  my ($self, $qop, $nc) = @_;
  my $valid;

  #
  # Either there's no QOP from the client and we require one, or the client does not
  # send a qop because they dont support what we want (e.g., auth-int).
  #
  # And, if there's a qop, then there must be a nonce count.
  #
  if(defined $qop) {
    $valid = $self->{qops}->{$qop} && $nc;
  }
  else {
    $valid = !%{$self->{qops}} && !defined $nc;
  }

  $valid;
}

sub _valid_opaque
{
  my ($self, $opaque) = @_;

  # IE 5 & 6 only sends opaque with the initial reply but we'll just ignore it regardless
  $self->_support_broken_browser || $opaque && $opaque eq $self->{opaque};
}

sub _header_complete
{
    my ($self, $header) = @_;

    $header &&
    $header->{realm} &&
    $header->{nonce} &&
    $header->{response} &&
    $header->{algorithm} &&
    exists $header->{username};
}

sub _build_auth_header
{
    my $self   = shift;
    my $header = $self->{response_header};

    if($header->{stale} || !$header->{nonce}) {
        $header->{nonce} = $self->_create_nonce;
    }

    my %no_quote;
    @no_quote{qw{algorithm stale}} = ();

    my @auth;
    while(my ($k, $v) = each %$header) {
      next unless $v;
      $v = quote($v) unless exists $no_quote{$k};
      push @auth, "$k=$v";
    }

    'Digest ' . join(', ', @auth);
}

sub _authorized
{
    my ($self, $header) = @_;
    return unless $self->_valid_nonce($header->{nonce});

    my $a1 = $self->_compute_a1($header);
    return unless $a1;

    my @fields = ($a1, $header->{nonce});
    if($header->{qop}) {
        push @fields, $header->{nc},
                      $header->{cnonce},
                      $header->{qop},
                      $self->_compute_a2($header);
    }
    else {
        push @fields, $self->_compute_a2($header);
    }

    checksum(@fields) eq $header->{response};
}

sub _compute_a1
{
    my ($self, $header) = @_;
    my $hash = $self->{password_db}->get($header->{realm}, $header->{username});

    if($hash && $header->{algorithm} && $header->{algorithm} eq $ALGORITHM_MD5_SESS) {
        $hash = checksum($hash, $header->{nonce}, $header->{cnonce});
    }

    $hash;
}

sub _compute_a2
{
    my ($self, $header) = @_;
    my @fields = ($self->_request->method, $header->{uri});

# Not yet...
#     if(defined $header->{qop} && $header->{qop} eq $QOP_AUTH_INT) {
#         # TODO: has body been decoded?
#       push @fields, checksum($self->_request->content->headers->to_string . "\015\012\015\012" . $self->_request->body);
#     }

    checksum(@fields);
}

1;