File Coverage

blib/lib/Plack/Middleware/RedirectSSL.pm

Criterion	Covered	Total	%
statement	73	74	98.6
branch	50	50	100.0
condition	29	30	96.6
subroutine	15	15	100.0
pod	5	5	100.0
total	172	174	98.8

use 5.006; use strict; use warnings;

package Plack::Middleware::RedirectSSL;
$Plack::Middleware::RedirectSSL::VERSION = '1.301';
# ABSTRACT: force all requests to use in-/secure connections

use parent 'Plack::Middleware';

use Plack::Util ();
use Plack::Util::Accessor qw( ssl hsts_header );
use Plack::Request ();

#                               seconds  minutes  hours   days  weeks
sub DEFAULT_STS_MAXAGE     () {      60  *    60  *  24  *   7  *  26 }
sub MIN_STS_PRELOAD_MAXAGE () {      60  *    60  *  24  * 365        }

sub call {
	my ( $self, $env ) = ( shift, @_ );

	my $do_ssl = $self->ssl ? 1 : 0;
	my $is_ssl = ( 'https' eq $env->{'psgi.url_scheme'} ) ? 1 : 0;

	if ( $is_ssl xor $do_ssl ) {
		my $m = $env->{'REQUEST_METHOD'};
		return [ 400, [qw( Content-Type text/plain )], [ 'Bad Request' ] ]
			if 'GET' ne $m and 'HEAD' ne $m;
		my $uri = Plack::Request->new( $env )->uri;
		$uri->scheme( $do_ssl ? 'https' : 'http' );
		return [ 301, [ Location => $uri ], [] ];
	}

	my $res = $self->app->( $env );

	return $res unless $is_ssl and my $hsts = $self->hsts_header;

	Plack::Util::response_cb( $res, sub {
		Plack::Util::header_set( $_[0][1], 'Strict-Transport-Security', $hsts );
	} );
}

sub hsts_policy {
	my ( $self, $policy ) = ( shift, @_ );
	return $self->{'hsts_policy'} unless @_;
	$self->hsts_header( render_sts_policy( $policy ) );
	$self->{'hsts'} = $policy ? $policy->{'max_age'} || '00' : 0; # legacy compat
	$self->{'hsts_policy'} = $policy;
}

sub hsts {
	my ( $self, $value ) = ( shift, @_ );
	return $self->{'hsts'} unless @_;
	$self->hsts_policy( ( $value or not defined $value )
		? { ( map %$_, $self->{'hsts_policy'} || () ), max_age => $value }
		: undef
	);
	$self->{'hsts'} = $value;
}

sub new {
	my $self = shift->SUPER::new( @_ );
	$self->ssl(1) if not defined $self->ssl;
	if    ( exists $self->{'hsts_policy'} ) { $self->hsts_policy( $self->{'hsts_policy'} ) }
	elsif ( exists $self->{'hsts'}        ) { $self->hsts       ( $self->{'hsts'} ) }
	elsif ( not $self->hsts_header        ) { $self->hsts_policy( {} ) }
	$self;
}

########################################################################

sub _callsite () { my $i; while ( my ( $p, $f, $l ) = caller ++$i ) { return " at $f line $l.\n" if __PACKAGE__ ne $p } '' }

sub render_sts_policy {
	my ( $opt ) = @_;

	die 'HSTS policy must be a single undef value or hash ref', _callsite
		if 1 != @_ or defined $opt and 'HASH' ne ref $opt;

	return undef if not defined $opt;

	my @directive = qw( max_age include_subdomains preload );

	{
		my %known = map +( $_, 1 ), @directive;
		my $unknown = join ', ', map "'$_'", sort grep !$known{ $_ }, keys %$opt;
		die "HSTS policy contains unknown directive(s) $unknown", _callsite if $unknown;
	}

	my ( $max_age, $include_subdomains, $preload ) = @$opt{ @directive };

	$max_age = defined $max_age
		? do { no warnings 'numeric'; int $max_age }
		: $preload ? MIN_STS_PRELOAD_MAXAGE : DEFAULT_STS_MAXAGE;

	die 'HSTS max_age 0 conflicts with setting other directives', _callsite
		if 0 == $max_age and ( $include_subdomains or $preload );

	if ( $preload ) {
		$include_subdomains = 1 unless defined $include_subdomains;
		die 'HSTS preload conflicts with disabled include_subdomains', _callsite unless $include_subdomains;
		die "HSTS preload requires longer max_age (got $max_age; minimum ".MIN_STS_PRELOAD_MAXAGE.')', _callsite
			if MIN_STS_PRELOAD_MAXAGE > $max_age;
	}

	# expose computed values back to the caller
	@$opt{ @directive } = ( $max_age, !!$include_subdomains, !!$preload );

	join '; ', "max-age=$max_age", ('includeSubDomains') x !!$include_subdomains, ('preload') x !!$preload;
}

1;

__END__