--- /dev/null
+#!/usr/bin/perl -T
+
+use strict;
+use warnings;
+use CGI;
+use HTML::TreeBuilder;
+use Storable qw(freeze thaw);
+use Date::Parse;
+use Email::Valid;
+#
+# Набор поддерживаемых действий. Хэш вида
+# "имя поля в запросе" => "функция обработчик"
+#
+my %actions = (
+ reply => \&reply,
+ edit => \&edit_comment,
+ delete => \&delete_comment,
+ move => \&move_comment,
+ newtopic=> \&new_topic,
+ newforum=> \&new_forum,
+ login => \&login,
+ register=>\®ister,
+ profile=>\&profile,
+ setrights=>\&set_rights,
+ openidlogin=>\&openid_login,
+ openidvfy =>\&openid_verify
+);
+
+
+
+my $cgi = new CGI;
+
+my $forum=get_forum_config();
+
+print STDERR "Config = $forum\nkeys= ".join(" ",keys %$forum)."\n" ;
+
+authorize_user($cgi,$forum);
+print STDERR "Request method = ".$cgi->request_method()."\n";
+if ($cgi->request_method ne "POST") {
+# Запрос к скрипту методом GET. Надо показать форму, если только это не
+# редирект от OpenId-сервера
+ if ($cgi->param('openidvfy')) {
+ openid_verify($cgi);
+ } else {
+ for my $param ($cgi->param) {
+# Среди параметров, указанных в URL ищем тот, который задает
+# действие
+ if (exists $actions{$param}) {
+# Мы, конечно уже проверили, что в названии параметра
+# нехороших символов нет, но чтобы perl в taint mode не
+# ругался...
+ if (allow_operation($param,$cgi,$forum)) {
+ show_template($1,$cgi,$forum) if $param=~/^(\w+)$/;
+ exit;
+ } else {
+ if (!$forum->{"authenticated"}) {
+ $cgi->param("returnto",$cgi->uri(-full=>1));
+ show_template("login",$cgi,$forum);
+ exit;
+
+ } else {
+ show_error($forum,"У Вас нет прав на выполнение этой
+ операции")
+ }
+ }
+ }
+ }
+ show_error($forum,"Некорректный вызов скрипта. Отсутствует параметр
+ действия");
+ }
+} else {
+ # Запрос методом POST. Вызываем обработчик
+ for my $param ($cgi->param) {
+ if (exists $actions{$param}) {
+ print STDERR "Calling $param handler\n";
+ $actions{$param}->($param,$cgi,$forum);
+ exit;
+ }
+ }
+ show_error($forum,"Некорректный вызов скрипта. Отсутствует параметр действия");
+}
+#
+# Поиск файла .forum вверх по дереву от $ENV{PATH_TRANSLATED}
+# Значение PATH_TRANSLATED считаем безопасным - наш web-сервер нам не
+# враг.
+# Возвращает список имя,значение, имя, значение который прививается в
+# хэш
+
+sub get_forum_config {
+ my @path=split("/",$1) if $ENV{PATH_TRANSLATED}=~/^(\S+)$/;
+ while (@path>1) {
+ pop @path;
+ if (-r (my $config=join("/",@path,".forum")) ) {
+ open F,"<",$config;
+ my %config;
+ while (<F>) {
+ s/#.*$//; #Drop comments;
+ $config{$1}=$2 if /(\w+)\s*=\s*(\S.*)$/;
+ }
+ close F;
+ #
+ # Если в конфиге отсутствует переменная templates, но
+ # рядом с конфигом присутствует директория templates,
+ # то шаблоны там.
+ #
+ if (! exists $config{"templates"}
+ && -d (my $filename = join("/",@path,"templates"))) {
+ print STDERR "get_forum_config: set templates to $filename\n";
+ $config{"templates"} = $filename;
+ }
+ #
+ # То же самое - параметр userdir и директория users
+ #
+ if (! exists $config{"userdir"}
+ && -d (my $filename = join("/",@path,"users"))) {
+ $config{"userdir"} = $filename;
+ }
+ #
+ # Если нет ссылки в конфиге на файл паролей или он не
+ # существует, выдаем ошибку. С офоромлением, так как шаблоны
+ # у нас уже есть
+ if (! exists $config{"passwd"}) {
+ show_error(\%config,"В конфигурации форума не указан файл пользователей");
+ exit;
+ }
+ if (!exists $config{"session"}) {
+ show_error(\%config,"В конфигурации форума не указан файл сессий");
+ exit;
+ }
+ $config{"authperiod"}="+1m" if (! exists $config{"authperiod"});
+ $config{"renewtime"} = "86000" if (!exists $config{"renewtime"});
+ return \%config;
+ }
+ }
+ #
+ # Выводим ошибку 404 без осмысленного оформления, так как данных форума
+ # мы не нашли
+ print "Status: 404\nContent-Type: text/html; charset=utf-8\n\n",
+ "<HTML><HEAD><TITLE>Форум не обнаружен</TITLE></HEAD><BODY>",
+ "<H!>Форум не найден</H!>",
+ "<p>Хвост URL, указанный при вызове скрипта показывает не на
+ форум</p>",
+ # To make IE think this page is user friendly
+ "<!--",("X" x 512),"--></body></html>\n";
+ exit;
+}
+#
+# Вывод сообщения об ошибке по шаблону форума
+# Шаблон должен содержать элемент с классом error.
+#
+sub show_error {
+ my ($cfg,$msg) = @_;
+ if ( -r $cfg->{"templates"}."/error.html") {
+ my $tree = HTML::TreeBuilder->new_from_file($cfg->{"templates"}."/error.html");
+ my $node= $tree->find_by_attribute('class','error');
+ my $body;
+ if (!$node) {
+ $body = $tree->find_by_tagname('body');
+ $body->push_content($node = new
+ HTML::Element('div','class'=>'error'));
+ }
+ $node->delete_content;
+ $node->push_content($msg);
+ print $cgi->header(-type=>'text/html',-charset=>'utf-8');
+ print $tree->as_HTML("<>&");
+ } else {
+ print STDERR "templates= $cfg->{templates}\n" ;
+ print $cgi->header(-type=>'text/html',-charset=>'utf-8');
+ print "<html><head><title>Ошибка конфигурации форума</title></head>",
+ "<body><h1>Ошибка конфигурации форума</h1><p>",
+ $cgi->escapeHTML($msg),"</p>",
+ "<p>При обработке этой ошибки не обнаружен шаблон сообщения об ошибке</p></body></html>";
+ }
+}
+#
+# Вывод шаблона формы. В шаблоне должна присутстовать форма с
+# именем, совпадающим с именем form. Если в $cgi есть параметры, имена
+# которых совпадают с именами полей этой формы, их значения
+# подставляются
+#
+sub show_template {
+ my ($form,$cgi,$forum) = @_;
+ print STDERR "show_template: form=$form forum=$forum\n";
+ my $filename=$forum->{"templates"}."/$form.html";
+ if (! -r $filename) {
+ show_error($forum,"Нет шаблона для операции $form");
+ exit;
+ }
+ my $tree = HTML::TreeBuilder->new_from_file($filename);
+ # Находим форму с классом $form
+ my $f = $tree->look_down("_tag","form",
+ "name",$form);
+ if (! defined $f) {
+ # Если не нашли - ругаемся
+ show_error($forum,"Шаблон для операции $form не содержит формы с
+ именем $form");
+ exit;
+ }
+ if (!$cgi->param("returnto")) {
+ $cgi->param("returnto", $cgi->referer||$cgi->url(-absolute=>1,-path_info=>1));
+
+ }
+ if (!$cgi->param($form)) {
+ $cgi->param($form,1);
+ }
+ #
+ # Если ранее была выставлена ошибка с помощью set_error, подставляем
+ # сообщение в элемент с классом error
+ #
+ if ($forum->{error_message}) {
+ my $errormsg = $tree->look_down("class"=>"error");
+ if ($errormsg) {
+ $errormsg->delete_content();
+ $errormsg->push_content($forum->{error_message});
+ }
+ }
+ if ($forum->{"authenticated"}) {
+ # Подставляем информацию о текущем пользователе если в шаблоне
+ # это предусмотрено
+ substitute_user_info($tree,$forum);
+ }
+ my %substituted;
+ for my $element($f->find_by_tag_name("textarea","input","select")) {
+ my $name = $f->attr("name");
+ $substituted{$name} = 1;
+ if (defined $cgi->param($name)) {
+ if ($f->tag eq "input") {
+ if ($f->attr("type") eq "check") {
+ if (grep($f->attr("value") eq $_,$cgi->param($name))) {
+ $f->attr("checked","");
+ } else {
+ $f->attr("checked",undef);
+ }
+
+ } elsif ($f->attr("type") eq
+ "radio") {
+ if ($f->attr("value") eq $cgi->param($name)) {
+ $f->attr("checked","");
+ } else {
+ $f->attr("checked",undef);
+ }
+ } else {
+ $f->attr("value",$cgi->param($name));
+ }
+ } elsif ($f->tag eq "textarea") {
+ $f->delete_content;
+ $f->push_content($cgi->param("name"));
+ } elsif ($f->tag eq "select") {
+ for my $option ($f->find_by_tag_name("option")) {
+ if (grep($option->attr("value") eq $_, $cgi-param("name"))) {
+ $option->attr("selected","");
+ } else {
+ $option->attr("selected",undef);
+ }
+ }
+
+ }
+ }
+
+ }
+ $f->attr("type","POST");
+ $f->attr("action",$cgi->url(-full=>1,-path_info=>1,-query=>0));
+ for my $required ($form,"returnto") {
+ if (!$substituted{$required}) {
+ my $element = new HTML::Element('input',
+ 'type' => 'hidden', 'name' => $required,
+ 'value'=> $cgi->param($required));
+ $f->push_content($element);
+ }
+ }
+
+
+ print
+ $cgi->header(type=>"text/html",charset=>"utf-8",($forum->{cookies}?(-cookie=>$forum->{cookies}):())),
+ $tree->as_HTML("<>&");
+}
+
+#
+# Подставляет в заданное поддерево информацию о пользователе
+#
+
+sub substitute_user_info {
+
+my ($tree,$forum) = @_;
+my %userinfo = %{$forum->{"authenticated"}};
+
+#
+# Специально обрабатываем поля user (должна быть ссылка) и avatar
+# (должен быть img).
+
+my $userlink = $tree->look_down("_tag"=>"a","class"=>"author");
+if ($userlink) {
+ $userlink->attr(href=>$userinfo{"userpage"});
+ $userlink->delete_content();
+ $userlink->push_content($userinfo{"user"});
+}
+delete $userinfo{"userpage"};
+delete $userinfo{"user"};
+my $avatar = $tree->look_down("_tag"=>"img","class"=>"avatar");
+if ($avatar) {
+ $avatar->attr(src=>$userinfo{"avatar"});
+}
+delete $userinfo{"avatar"};
+
+while (my ($field,$value)=each %userinfo) {
+ my $element = $tree->look_down("class","a".$field);
+ if ($element) {
+ $element->delete_content();
+ #
+ # FixME - allow HTML in author attributes
+ $element->push_content($value);
+ }
+
+}
+
+}
+#
+# Авторизует зарегистрированного пользователя.
+# 1. Проверяет куку если есть
+#
+
+sub authorize_user {
+ ($cgi,$forum) = @_;
+ if (my $session=$cgi->cookie("slsession")) {
+ # Пользователь имеет куку
+ my %sessbase;
+ dbmopen %sessbase,$forum->{"session"},0644;
+ if (exists($sessbase{$session})) {
+ my ($user,$expires,$ip)=split(";", $sessbase{$session});
+ if (!defined $ip|| $ip eq $ENV{'REMOTE_ADDR'}) {
+ my %userbase;
+ dbmopen %userbase,$forum->{"passwd"},0644;
+ if ( exists($userbase{$user})) {
+ my $userinfo = thaw($userbase{$user});
+ delete $userinfo->{"passwd"};
+ $userinfo->{"user"} = $user;
+ if ($expires-time()< $forum->{"renewtime" }) {
+ delete $sessbase{$session};
+ newsession(\%sessbase,$forum,$user,$ip);
+ }
+ $forum->{"authenticated"}=$userinfo;
+ }
+ dbmclose %userbase;
+ }
+ }
+ dbmclose %sessbase;
+ }
+}
+
+#
+# Создает новую сессию для пользователя и подготавливает куку которую
+# сохраняет в хэше конфигурации форума
+#
+sub newsession {
+ my ($base,$forum,$user,$bindip) = @_;
+ if (!defined $base) {
+ $base = {};
+ dbmopen %$base,$forum->{"session"},0644;
+ }
+ my $sessname;
+ my $t = time();
+ my ($u,$expires,$ip);
+ do {
+ $sessname = sprintf("%08x",rand(0xffffffff));
+ if ($base->{"sessname"}) {
+ ($u,$expires,$ip) = split ";", $base->{$sessname};
+ delete $base->{$sessname} if $expires < $t;
+ }
+ } while ($base->{$sessname});
+ my $cookie = $cgi->cookie(-name=>"slsession",
+ -expires => $forum->{"authperiod"},-value=> $sessname);
+ $base->{$sessname}=$user.";".str2time($cookie->expires()).
+ ($ip?";$ENV{'REMOTE_ADDR'}":"");
+
+ $forum->{'cookie'}=[ $cookie,
+ $cgi->cookie(-name=>"sluser",-value=>$user,-expires =>
+ $forum->{authperiod})];
+}
+#
+# Выполняет аутентикацию пользователя по логину и паролю и
+# создает для него сессию.
+#
+sub authenticate {
+ my ($cgi,$forum) = @_;
+ if ($cgi->param("openidsite")) {
+ my $openid_url = sprintf($cgi->param("openidsite",$cgi->param("user")));
+ openidstart($cgi,$openid_url);
+ }
+ my %userbase;
+ dbmopen %userbase,$forum->{"passwd"},0644;
+ my $user = $cgi->param("user");
+ if (! $userbase{$user}) {
+ set_error($forum,"Неверное имя пользователя или пароль");
+ return undef;
+ }
+ my $userinfo = thaw($userbase{$user}) ;
+ dbmclose %userbase;
+ if (crypt($user,$userinfo->{passwd}) eq $userinfo->{passwd}) {
+ delete $userinfo->{"passwd"};
+ $userinfo->{"user"} = $user;
+ newsession(undef,$forum,$user);
+ $forum->{"authenticated"} = $userinfo;
+ } else {
+ set_error($forum,"Неверное имя пользователя или пароль");
+ }
+}
+#
+# Запоминает сообщение об ошибке для последующего вывода show_template
+#
+sub set_error {
+ my ($forum,$message) = @_;
+ $forum->{error_message} = $message;
+}
+#
+# Выводит текущий шаблно с сообщением об ошибке
+#
+sub form_error {
+ my ($form_name,$cgi,$forum,$msg) = @_;
+ set_error($forum,$msg);
+ show_template($form_name,$cgi,$forum);
+ exit;
+}
+#
+# Обработка результатов заполнения формы регистрации.
+#
+#
+sub register {
+ my ($formname,$cgi,$forum) = @_;
+ #
+ # Возможные ошибки:
+ # 1 Такой юзер уже есть
+ #
+ # не заполнено поле user
+ if (!$cgi->param("user")) {
+ form_error($formname,$cgi,$forum, "Не заполнено имя пользователя");
+ }
+ # или поле password
+ if (!$cgi->param("pass1")) {
+ form_error($formname,$cgi,$forum,"Не указан пароль");
+ }
+ # Копии пароля не совпали
+ if ($cgi->param("pass2") ne $cgi->param("pass1")) {
+ form_error($formname,$cgi,$forum,"Ошибка при вводе пароля");
+ }
+ my $user = $cgi->param("user");
+ # Не указаны поля, перечисленные в скрытом поле required
+ if ($cgi->param("required")) {
+ foreach my $field (split(/\s*,\s*/,$cgi->param('required'))) {
+ if (!$cgi->param($field)) {
+ form_error($formname,$cgi,$forum,"Не заполнено обязательное поле $field");
+ }
+ }
+ }
+ my %userbase;
+ dbmopen %userbase,$forum->{"passwd"},0644
+ or form_error($formname,$cgi,$forum,"Ошибка открытия файла паролей $!");
+ if ($userbase{$cgi->param("user")}) {
+ dbmclose %userbase;
+ form_error($formname,$cgi,$forum,"Имя пользователя '".$cgi->param("user"). "' уже занято");
+ }
+ if ($cgi->param("email") && ! Email::Valid->address($cgi->param("email"))) {
+ form_error($formname,$cgi,$forum,"Некорректный E-Mail адрес");
+ }
+ my $saltstring = 'ABCDEFGHIJKLMNOPQRSTUVWXUZabcdefghijklmnopqrstuvwxuz0123456789./';
+ my $salt = substr($saltstring,int(rand(64)),1).
+ substr($altstring,int(rand(64)),1);
+ my $password=crypt($cgi->param("pass1",$salt));
+ my $userinfo = {passwd=>$password};
+ # Удаляем лишние поля
+ $cgi->delete("required");
+ $cgi->delete("register");
+ $cgi->delete("user");
+ $cgi->delete("pass1");
+ $cgi->delete("pass2");
+ foreach my $field (split(/\s*,\s*/,$cgi->param('ignore'))) {
+ if (!$cgi->param($field)) {
+ $cgi->delete($field);
+ }
+ }
+ my $returnto = $cgi->param("returnto");
+ $cgi->delete("returnto");
+ # Если есть аватар в файле, то сохраняем этот файл и формируем URL
+ # на него.
+ if ($cgi->param("avatarfile" )) {
+ my $f = $cgi->upload("avatarfile");
+ binmode $f,":bytes";
+ my $out;
+ my $filename = $1 if $cgi->param("avatarfile")=~/([^\/\\]+)$/;
+ open $out,">",$forum->{"userdir"}."/".$filename;
+ binmode $out,":bytes";
+ my $buffer;
+ while (my $bytes = read($f,$buffer,4096)) {
+ print $out $buffer;
+ }
+ close $f;
+ close $out;
+ $userinfo->{'avatar'}= $forum->{"userurl"}."/".$filename;
+ $cgi->delete("avatar");
+ $cgi->delete("avatarfile");
+ }
+
+ foreach my $param ($cgi->param) {
+ $userinfo->{$param} = $cgi->param($param);
+ }
+ $userinfo->{registered} = time;
+ if (exists $forum->{default_status}) {
+ $userinfo->{status} = $forum->{default_status};
+ }
+ print STDERR "registering user $user\n";
+ $userbase{$user} = freeze($userinfo);
+ dbmclose %userbase;
+ newsession(undef,$forum,$user);
+ if (defined $returnto) {
+ forum_redirect($returnto)
+ } else {
+ forum_redirect($cgi->url(-base=>1).$ENV{PATH_INFO});
+ }
+
+}
+
+sub allow_operation {
+ my ($operation,$cgi,$forum) = @_;
+ return 1 if (grep $operation eq $_,"register","login","reply");
+
+ return 1;
+}
projects / oss / stilllife.git / commitdiff