XREAの共用SSLアクセスでCGI::Application::Plugin::Authenticationの認証遷移を機能させる

CGI::Application::Plugin::Authenticationというとても長い名前のモジュールですが、これは、CGI::Appicationで認証を実現するモジュールです。これなんですが、現在実行されているスクリプトのURLを絶対パスで取得する部分があります。$query->self_url ていうやつ。通常はそんなに問題はないんですけれども、またまたXREAの共用SSLサーバを通すと、認証が終わったあとの遷移がちゃんと動きません。よって、やっぱりパッチします。パッチっていっても、元のモジュールから該当部引っ張ってきて、$query->self_urlを、$query->url(-relative=>1, -query=>1)に書き換えているだけだぞ。

#!/usr/bin/perl
package MyWebApp;
use base 'CGI::Application';
use strict;
use warnings;
use utf8;
use CGI::Application::Plugin::Authentication;
cgi_application_plugin_authentication_fixup();


#以下略


# CGI::Application::Plugin::AuthenticationをXREAの共通SSLに対応させるパッチ
sub cgi_application_plugin_authentication_fixup {
  package CGI::Application::Plugin::Authentication;
  no warnings 'redefine';
*login_box = sub  {
    my $self        = shift;
    my $query       = $self->_cgiapp->query;
    my $credentials = $self->credentials;
    my $runmode     = $self->_cgiapp->get_current_runmode;
#    my $destination = $query->param('destination') || $query->self_url;
    my $destination = $query->param('destination') || './'
                     .$query->url(-relative=>1, -query=>1);
#    my $action      = $query->url( -absolute => 1 );
    my $action      = './'.$query->url(-relative=>1);
    my $username    = $credentials->[0];
    my $password    = $credentials->[1];
    my $login_form  = $self->_config->{LOGIN_FORM} || {};
    my %options = (
        TITLE                   => 'Sign In',
        USERNAME_LABEL          => 'User Name',
        PASSWORD_LABEL          => 'Password',
        SUBMIT_LABEL            => 'Sign In',
        COMMENT                 => 'Please enter your username and '
                                  .'password in the fields below.',
        REMEMBERUSER_OPTION     => 1,
        REMEMBERUSER_LABEL      => 'Remember User Name',
        REMEMBERUSER_COOKIENAME => 'CAPAUTHTOKEN',
        REGISTER_URL            => '',
        REGISTER_LABEL          => 'Register Now!',
        FORGOTPASSWORD_URL      => '',
        FORGOTPASSWORD_LABEL    => 'Forgot Password?',
        INVALIDPASSWORD_MESSAGE => 'Invalid username or password'
                                  .'<br />(login attempt %d)',
        INCLUDE_STYLESHEET      => 1,
        %$login_form,
    );

    my $messages = '';
    if ( my $attempts = $self->login_attempts ) {
        $messages .= '<li class="warning">'
                  . sprintf($options{INVALIDPASSWORD_MESSAGE}, $attempts) . '</li>';
    } elsif ($options{COMMENT}) {
        $messages .= "<li>$options{COMMENT}</li>";
    }

    my $tabindex = 3;
    my ($rememberuser, $username_value, $register,
        $forgotpassword, $javascript, $style) = ('','','','','','');
    if ($options{FOCUS_FORM_ONLOAD}) {
        $javascript .= "document.loginform.${username}.focus();\n";
    }
    if ($options{REMEMBERUSER_OPTION}) {
        $rememberuser = qq[<input id="authen_rememberuserfield" ]
                       .qq[tabindex="$tabindex" type="checkbox" ]
                       .qq[name="authen_rememberuser" value="1" />]
                       .qq[$options{REMEMBERUSER_LABEL}<br />];
        $tabindex++;
        my $query = $self->_cgiapp->query;
        $username_value = $query->param($username)
                       || $query->cookie($options{REMEMBERUSER_COOKIENAME})
                       || '';
        $javascript .= "document.loginform.${username}.select();\n" if $username_value;
    }
    my $submit_tabindex = $tabindex++;
    if ($options{REGISTER_URL}) {
        $register = qq[<a href="$options{REGISTER_URL}" ]
                   .qq[id="authen_registerlink" tabindex="$tabindex">]
                   .qq[$options{REGISTER_LABEL}</a>];
        $tabindex++;
    }
    if ($options{FORGOTPASSWORD_URL}) {
        $forgotpassword = qq[<a href="$options{FORGOTPASSWORD_URL}" ]
                         .qq[id="authen_forgotpasswordlink" tabindex="$tabindex">]
                         .qq[$options{FORGOTPASSWORD_LABEL}</a>];
        $tabindex++;
    }
    if ($options{INCLUDE_STYLESHEET}) {
        my $login_styles = $self->login_styles;
        $style = <<EOS;
<style type="text/css">
<!--/* <![CDATA[ */
$login_styles
/* ]]> */-->
</style>
EOS
    }
    if ($javascript) {
        $javascript = qq[<script type="text/javascript" ]
                     .qq[language="JavaScript">$javascript</script>];
    }

    my $html .= <<END;
$style
<form name="loginform" method="post" action="${action}">
  <div class="login">
    <div class="login_header">
      $options{TITLE}
    </div>
    <div class="login_content">
      <ul class="message">
${messages}
      </ul>
      <fieldset>
        <label for="${username}">$options{USERNAME_LABEL}</label>
        <input id="authen_loginfield" tabindex="1" type="text"
          name="${username}" size="20" value="$username_value" /><br />
        <label for="${password}">$options{PASSWORD_LABEL}</label>
        <input id="authen_passwordfield" tabindex="2" type="password"
          name="${password}" size="20" /><br />
        ${rememberuser}
      </fieldset>
    </div>
    <div class="login_footer">
      <div class="buttons">
        <input id="authen_loginbutton" tabindex="${submit_tabindex}"
          type="submit" name="authen_loginbutton" value="$options{SUBMIT_LABEL}"
          class="button" />
        ${register}
        ${forgotpassword}
      </div>
    </div>
  </div>
  <input type="hidden" name="destination" value="${destination}" />
  <input type="hidden" name="rm" value="${runmode}" />
</form>
$javascript
END

    return $html;
};

    return 1;
}

デフォルトの認証ダイアログがイヤなら、このパッチ内で書き換えてしまう手もあるね。

このエントリを書くにあたって、

404 Blog Not Found:perl - パッチなしでパッチする

を参考にしました。