package gateway;
use strict;

#===============================================================================
# gateway.cgi: Perl-CGIスクリプトに簡易認証システムを組み込む
# The latest version is here: http://confetto.s31.xrea.com/
# This script use a japanese character code set: Shift_JIS
#===============================================================================
# Copyright (c) 2003-2007 confetto. <confetto@s31.xrea.com>
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.
#===============================================================================
my $rcsid=q$Id: gateway.cgi,v 1.4 2007/04/18 16:08:52 confetto Exp $;

#===============================================================================
# 初期設定
#===============================================================================

#### アカウントの設定
# 下記の例にならって、ユーザ名とパスワードを対にしてコロン(:)で区切り、1行に1ア
# カウントずつ並べてください。半角英数字のみ使えます。余計な空行や空白を含めない
# でください。END_OF_USERNAMESという行はいじらないでください。
my $USERNAMES = <<'END_OF_USERNAMES';
test:test
guest:guest
END_OF_USERNAMES

#### 外部のユーザ認証ファイルのパス
# 使う場合は指定。ApacheのBASIC認証が使うユーザ認証ファイル(.htpasswd)と同じ形式
# のテキストファイルで、パスワードがcrypt()で暗号化されたものであれば、アカウン
# ト情報として使うことができます。
my $PASSWD_FILE = '';

#### ホームページのURI
# 認証フォームからの戻り先URIを指定してください。相対URIを指定する場合は、組み込
# み対象のCGIスクリプトからの相対で指定してください。
my $HOME_PAGE = '/';

#### 広告等挿入部
# 認証ページの最上部に広告等を挿入できます。'<!-- HTML -->'の代わりにHTMLコード
# 等を挿入してください。複数行に渡っても構いません。
my $AD_BLOCK = <<'END_OF_AD_BLOCK';
<!-- HTML -->
END_OF_AD_BLOCK

#### 外部スタイルシートのURI
# 認証ページに適用するスタイルシート(CSS)のURIを指定してください。相対URIを指定
# する場合は、組み込む対象のCGIスクリプトからの相対で指定してください。
my $CSS_FILE = 'gateway.css';

#### スクリプトのURI
# 組み込み対象のCGIスクリプトのURIです。通常は自動的に取得しますが、取得がうまく
# いかないときなどは手動で指定します。
my $SCRIPT_URI = '';

#### クッキーのパス
# 指定しなければ「対象のCGIスクリプトのあるディレクトリ」が既定値です。
my $COOKIE_PATH = '';

#### クッキーの有効期限(日数)
# フォームにパスワードなどを記憶するためのクッキーの有効期限です。
my $COOKIE_EXPIRE = 30; # 30日

# クッキーの名前
my $FORM_COOKIE_NAME = 'gatewayform'; # フォーム用
my $TEMP_COOKIE_NAME = 'gatewaytemp'; # セッション用

# スクリプトの文字符号化方式
my $ENCODING = 'Shift_JIS';

#===============================================================================
# ルーチン
#===============================================================================

my($VERSION) = $rcsid =~ /,v ([\d.]+)/;

$SCRIPT_URI ||= script_uri('relative') || './';

if ($COOKIE_PATH eq '') {
	$COOKIE_PATH = script_uri();
	$COOKIE_PATH =~ s|[^/]+$||;
}

&{ sub {
	# クッキーを取得して認証できれば抜ける
	return if authorize(split /:/, cookie($TEMP_COOKIE_NAME));

	# パラメタを取得して認証
	my $params = read_params();

	# 認証できればクッキーを発行して抜ける
	if (authorize(@$params{'_username','_password'})) {
		set_cookies($params);
		return;
	}

	print_header();

	if (defined $params->{_username}) {
		print_html_start(title => '認証に失敗しました');
		print_auth_error();
	} else {
		print_html_start(
			title  => 'ユーザ名とパスワードを入力してください',
			onload => 'document.forms.auth._username.focus()'
		);
		print_auth_form();
	}

	print_html_end();

	exit;
} };

#===============================================================================
# サブルーチン
#===============================================================================

#
# 認証フォームを出力する
#
sub print_auth_form {
	my($username, $password) = split /:/, cookie($FORM_COOKIE_NAME);
	my $savecookie = ' checked="checked"' if $username;

	print <<END_OF_HTML;
<p>Cookieを無効にしているとログインできませんのでご注意ください。</p>
<form action="$SCRIPT_URI" method="post" id="auth">
<table>
<tbody>
<tr>
 <th><label for="username" accesskey="u">ユーザ名</label></th>
 <td><input name="_username" value="$username" id="username" size="20" /></td>
</tr>
<tr>
 <th><label for="password" accesskey="p">パスワード</label></th>
 <td><input type="password" name="_password" value="$password"
  id="password" size="20" /></td>
</tr>
</tbody>
</table>
<ul>
 <li><label accesskey="s"><input type="checkbox" name="_savecookie"
  value="1" $savecookie />パスワードを保存する</label></li>
 <li><input type="submit" value="認証する" /></li>
</ul>
</form>
<ul>
 <li><a href="$HOME_PAGE" accesskey="h">ホームに戻る</a></li>
</ul>
END_OF_HTML
}

#
# 認証エラーを出力する
#
sub print_auth_error {
		print <<END_OF_HTML;
<p>ユーザ名が存在しないか、パスワードが違います。</p>
<ul>
 <li><a href="$SCRIPT_URI" accesskey="f">認証画面に戻る</a></li>
 <li><a href="$HOME_PAGE" accesskey="h">ホームに戻る</a></li>
</ul>
END_OF_HTML
}

#
# エラーを出力して終了する
#
sub error {
	my($message) = @_;

	print_header();
	print_html_start(title => 'エラー');
	print qq'<p>$message</p>';
	print_html_end();
	exit;
}

#
# HTTPレスポンスヘッダを出力する
#
sub print_header {
	print <<END_OF_HEADER;
Chache-Control: no-chache
Content-Type: text/html; charset=$ENCODING
Content-Script-Type: text/javascript
Content-Language: ja

END_OF_HEADER
}

#
# HTMLの最初の部分を出力する
#
sub print_html_start {
	my %args = (title => '無題', @_);

	print qq'<?xml version="1.0" encoding="$ENCODING"?>';
	print	'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"',
		' "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">';
	print	'<html xmlns="http://www.w3.org/1999/xhtml">';
	print	'<head>';
	print qq'<link rel="stylesheet" href="$CSS_FILE" type="text/css" />';
	print qq'<link rel="contents" href="$HOME_PAGE" />';
	print	'<link rev="made" href="http://confetto.s31.xrea.com/" />';
	print qq'<title>$args{title}</title>';
	print	'</head>';
	print $args{onload} ? qq'<body onload="$args{onload}">' : '<body>';
	print qq'$AD_BLOCK<h1>$args{title}</h1>';
}

#
# HTMLの最後の部分を出力する
#
sub print_html_end {
	print <<END_OF_HTML;
<address><a href="http://confetto.s31.xrea.com/"
 rev="made">gateway.cgi</a> $VERSION</address>
</body>
</html>
END_OF_HTML
}

#
# パラメタを読み込みハッシュ(のリファレンス)で返す
#
sub read_params {
	my($buffer, $name, $value, %params);

	read STDIN, $buffer, $ENV{CONTENT_LENGTH};
	$ENV{CONTENT_LENGTH} = 0;
	foreach (split /&/, $buffer) {
		($name, $value) = split /=/;
		$value =~ tr/+/ /;
		$value = unescape($value);
		$params{$name} = $value;
	}
	wantarray ? %params : \%params;
}

#
# 認証を行う
#  ユーザ名とパスワードを引数に取り、認証に成功すれば1、さもなくば
#  undefを返す。
#
sub authorize {
	my($username, $password) = @_;
	my %passwds = split /\n|:/, $USERNAMES;

	return   if !$username or !$password;
	return 1 if $passwds{$username} eq $password;
	return   if $PASSWD_FILE eq '';

	open IN, $PASSWD_FILE
		or error("ユーザ認証ファイルを開けません: $!");
	while (<IN>) {
		chomp;
		my($username_, $password_) = split /:/;
		next if $username_ ne $username;
		next if $password_ ne crypt($password, $password_);
		return 1;
	}
	close IN;

	return undef;
}

#
# クッキーを発行する
#  フォーム用とセッション用のクッキー2つを、Set-Cookieヘッダを出力して
#  発行する。
#
sub set_cookies {
	my($params) = @_;
	my $value   = join ':', @$params{'_username','_password'};
	my $expdays = $$params{_savecookie} ? $COOKIE_EXPIRE : -1;
	my $cookie1 = cookie($FORM_COOKIE_NAME, $value, $expdays);
	my $cookie2 = cookie($TEMP_COOKIE_NAME, $value, undef, $COOKIE_PATH);

	print "Set-Cookie: $_\n" foreach ($cookie1, $cookie2);
}

#
# クッキーの取得および生成(汎用)
#
sub cookie {
	my($name, $value, $expdays, $path) = @_;

	if ($value) {
		my $cookie  = "$name=" . escape($value);
		if ($expdays) {
		     my $expires = expires(time + $expdays*24*60*60);
			$cookie .= "; expires=$expires";
		}
		$cookie .= "; path=$path" if $path;
		return $cookie;
	} else {
		($value) = $ENV{HTTP_COOKIE} =~ /$name=([^;]*)/;
		return unescape($value);
	}
}

#
# クッキーの有効期限の文字列を生成する
#
sub expires {
	my($time) = @_;
	my @mons  = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
	my @wdays = qw(Sun Mon Tue Wed Thu Fri Sat);
	my($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($time);
	return sprintf("%s, %02d-%s-%04d %02d:%02d:%02d GMT",
		$wdays[$wday],$mday,$mons[$mon],$year+1900,$hour,$min,$sec);
}

#
# URIエスケープ・アンエスケープする
# 出典: http://www.din.or.jp/~ohzaki/perl.htm#JP_Escape
#
sub escape {
	my $s = shift;
	$s =~ s/(\W)/'%' . unpack('H2', $1)/eg;
	return $s;
}
sub unescape {
	my $s = shift;
	$s =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/pack("C", hex($1))/eg;
	return $s;
}

#
# スクリプトのURIを取得する
# 参考: CGI.pm version 3.04
#
sub script_uri {
	my($format) = @_;
	my $uri = $ENV{SCRIPT_NAME};

	if (exists $ENV{REQUEST_URI}) {
		$uri =  unescape($ENV{REQUEST_URI});
		$uri =~ s/\?.+$//;
		if (exists $ENV{PATH_INFO}) {
		     my $path = unescape($ENV{PATH_INFO});
			$uri  =~ s/\Q$path\E$//i;
		}
	}
	$uri =~ s|([^\w.%;&?/\\:+=~-])|'%' . unpack('H2', $1)|eg;
	$uri =~ s|.*/|| if $format eq 'relative';
	return $uri;
}

1;