Ecosyste.ms: Awesome

An open API service indexing awesome lists of open source software.

Awesome Lists | Featured Topics | Projects

https://github.com/ap/plack-middleware-redirectssl

force all requests to use in-/secure connections
https://github.com/ap/plack-middleware-redirectssl

https perl plack psgi

Last synced: about 2 months ago
JSON representation

force all requests to use in-/secure connections

Awesome Lists containing this project

README 

        
use 5.006; use strict; use warnings;



package Plack::Middleware::RedirectSSL;



our $VERSION = '1.302';



BEGIN { require Plack::Middleware; our @ISA = '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__



=pod



=encoding UTF-8



=head1 NAME



Plack::Middleware::RedirectSSL - force all requests to use in-/secure connections



=head1 SYNOPSIS



 # in app.psgi

 use Plack::Builder;

 

 builder {

     enable 'RedirectSSL';

     $app;

 };



=head1 DESCRIPTION



This middleware intercepts requests using either the C or C scheme

and redirects them to the same URI under respective other scheme.



=head1 CONFIGURATION OPTIONS



=over 4



=item C



Specifies the direction of redirects.

If true, requests using C will be redirected to C.

If false, requests using C will be redirected to plain C.



Defaults to true if not specified during construction.



=item C



Specifies an arbitrary string value for the C header.

If false, no such header will be sent.



=item C



Specifies a value to pass to C>

and updates the C option with the returned value.



 enable 'RedirectSSL', hsts_policy => { include_subdomains => 1 };



Defaults to an HSTS policy with default values,

which is a C of 26Eweeks and no other directives.



=item C



Use of this option is L.



Specifies a C value for the C option,

preserving all other existing C directives, if any.

If undef, uses a C of 26Eweeks.

If otherwise false, sets C to C.

(If you really want a C value of 0, use C<'00'>, C<'0E0'> or C<'0 but true'>.)



=back



=head1 FUNCTIONS



=head2 C



Takes either a hash reference containing an HSTS policy or C,

and returns the corresponding C header value.



 my $policy = { include_subdomains => 1 };

 printf "Strict-Transport-Security: %s\n", render_sts_policy $policy;

 # Strict-Transport-Security: max-age=15724800; includeSubDomains



As a side effect, validates the policy and

updates the hash with the ultimate value of every directive after computing defaults.



 use Data::Dumper; local $Data::Dumper::Terse = 1;

 print +Dumper $policy;

 # {

 #   'max_age' => 15724800,

 #   'include_subdomains' => 1,

 #   'preload' => ''

 # }



The following directives are supported:



=over 4



=item C



Integer value for the C directive.



If missing or undefined, it will normally default to 26Eweeks.



But if the C directive is true, it will default to 365Edays

and may not be set to any smaller value.



If 0 (which unpublishes a previous HSTS policy), no other directives may be set.



=item C



Boolean; whether to include the C directive.



If missing or undefined, it will normally default to false.



But if the C directive is true, it will defaults to true

and may not be set to false.



=item C



Boolean; whether to include the C directive.



=back



=head1 SEE ALSO



=over 4



=item *



L



If your L application runs behind a reverse proxy that unwraps SSL connections

then you will need to put this middleware in front of RedirectSSL.



=item *



L6797, I|http://tools.ietf.org/html/rfc6797>



=item *



L



Specification of the C directive

and submission form for inclusion into the Google Chrome preload list

(also used by most other browsers)



=back



=cut