t/lib/Catty/Controller/Root.pm

   1 package Catty::Controller::Root;
   2
   3 use strict;
   4 use warnings;
   5 use base qw/ Catalyst::Controller /;
   6
   7 use Cwd;
   8 use MIME::Base64;
   9 use Encode ();
  10
  11 __PACKAGE__->config( namespace => '' );
  12
  13 sub default : Private {
  14     my ( $self, $context ) = @_;
  15     my $html = html( "Root", "This is the root page" );
  16     $context->response->content_type("text/html");
  17     $context->response->output($html);
  18 }
  19
  20 sub hello : Global {
  21     my ( $self, $context ) = @_;
  22     my $str = Encode::encode('utf-8', "\x{263A}"); # ☺
  23     my $html = html( "Hello", "Hi there! $str" );
  24     $context->response->content_type("text/html; charset=utf-8");
  25     $context->response->output($html);
  26 }
  27
  28 # absolute redirect
  29 sub hi : Global {
  30     my ( $self, $context ) = @_;
  31     my $where = $context->uri_for('hello');
  32     $context->response->redirect($where);
  33     return;
  34 }
  35
  36 # partial (relative) redirect
  37 sub greetings : Global {
  38     my ( $self, $context ) = @_;
  39     $context->response->redirect("hello");
  40     return;
  41 }
  42
  43 # redirect to a redirect
  44 sub bonjour : Global {
  45     my ( $self, $context ) = @_;
  46     my $where = $context->uri_for('hi');
  47     $context->response->redirect($where);
  48     return;
  49 }
  50
  51 sub check_auth_basic : Global {
  52     my ( $self, $context ) = @_;
  53
  54     my $auth = $context->req->headers->authorization;
  55     ($auth) = $auth =~ /Basic\s(.*)/i;
  56     $auth = decode_base64($auth);
  57
  58     if ( $auth eq "user:pass" ) {
  59         my $html = html( "Auth", "This is the auth page" );
  60         $context->response->content_type("text/html");
  61         $context->response->output($html);
  62         return $context;
  63     } else {
  64         my $html = html( "Auth", "Auth Failed!" );
  65         $context->response->content_type("text/html");
  66         $context->response->output($html);
  67         $context->response->status("401");
  68         return $context;
  69     }
  70 }
  71
  72 sub redirect_with_500 : Global {
  73     my ( $self, $c ) = @_;
  74     $DB::single = 1;
  75     $c->res->redirect( $c->uri_for("/bonjour"));
  76     die "erk!";
  77 }
  78
  79 sub die : Global {
  80     my ( $self, $context ) = @_;
  81     my $html = html( "Die", "This is the die page" );
  82     $context->response->content_type("text/html");
  83     $context->response->output($html);
  84     die "erk!";
  85 }
  86
  87 sub name : Global {
  88     my ($self, $c) = @_;
  89
  90     my $html = html( $c->config->{name}, "This is the die page" );
  91     $c->response->content_type("text/html");
  92     $c->response->output($html);
  93 }
  94
  95 sub host : Global {
  96     my ($self, $c) = @_;
  97
  98     my $host = $c->req->header('Host') || "<undef>";
  99     my $html = html( $c->config->{name}, "Host: $host" );
 100     $c->response->content_type("text/html");
 101     $c->response->output($html);
 102 }
 103
 104 sub html {
 105     my ( $title, $body ) = @_;
 106     return qq{
 107 <html>
 108 <head><title>$title</title></head>
 109 <body>
 110 $body
 111 <a href="/hello/">Hello</a>.
 112 </body></html>
 113 };
 114 }
 115
 116 sub gzipped : Global {
 117     my ( $self, $c ) = @_;
 118
 119   # If done properly this test should check the accept-encoding header, but we
 120   # control both ends, so just always gzip the response.
 121     require Compress::Zlib;
 122
 123     my $html = html( "Hello", "Hi there! ☺" );
 124     $c->response->content_type("text/html; charset=utf-8");
 125     $c->response->output( Compress::Zlib::memGzip($html) );
 126     $c->response->content_encoding('gzip');
 127     $c->response->headers->push_header( 'Vary', 'Accept-Encoding' );
 128 }
 129
 130 sub user_agent : Global {
 131     my ( $self, $c ) = @_;
 132
 133     my $html = html($c->req->user_agent, $c->req->user_agent);
 134     $c->response->content_type("text/html; charset=utf-8");
 135     $c->response->output( $html );
 136
 137 }
 138
 139 # per https://rt.cpan.org/Ticket/Display.html?id=36442
 140 sub bad_content_encoding :Global {
 141     my($self, $c) = @_;
 142     $c->res->content_encoding('duff');
 143     $c->res->body('foo');
 144 }
 145
 146 sub redirect_to_utf8_upgraded_string {
 147     my($self, $c) = @_;
 148     my $where = $c->uri_for('hello')->stringify;
 149     utf8::upgrade($where);
 150     $c->res->redirect($where);
 151 }
 152
 153 1;
 154