#!/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 () { 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", "Форум не обнаружен", "Форум не найден", "

Хвост URL, указанный при вызове скрипта показывает не на форум

", # To make IE think this page is user friendly "\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 "Ошибка конфигурации форума", "

Ошибка конфигурации форума

", $cgi->escapeHTML($msg),"

", "

При обработке этой ошибки не обнаружен шаблон сообщения об ошибке

"; } } # # Вывод шаблона формы. В шаблоне должна присутстовать форма с # именем, совпадающим с именем 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($saltstring,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; }