#!/usr/bin/perl -T # # Stil Life forum. Copyright (c) by Victor B. Wagner, 2008 # This program distributed under GNU Affero General Public License v3 or # above # http://www.gnu.org/licenses/agpl.html # # Вкратце: Если вы используете этот скрипт на своем сайте, Вы обязаны # сделать доступным его исходный текст. В частности, если Вы внесли # какие-либо изменения, вы должны эти изменения опубликовать. # # Home site of this program http://vitus.wagner.pp.ru/stilllife # 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; print STDERR "--------------------\n"; my $forum=get_forum_config(); authorize_user($cgi,$forum); if ($cgi->request_method ne "POST") { # Запрос к скрипту методом GET. Надо показать форму, если только это не # редирект от OpenId-сервера if ($cgi->param('openidvfy')) { openid_verify($cgi); } elsif ($cgi->param("logout")) { logout('logout',$cgi,$forum); } 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}) { $actions{$param}->($param,$cgi,$forum); exit; } } print STDERR "Получены параметры ",join(" ",$cgi->param),"\n"; show_error($forum,"Некорректный вызов скрипта. Отсутствует параметр действия"); } sub dir2url { my ($cgi,$dir) = @_; my $prefix=$cgi->url(-base=>1); my $pos=rindex $ENV{'PATH_TRANSLATED'},$ENV{'PATH_INFO'}; if ($pos <0 && $ENV{'PATH_INFO'}=~m!(/\~\w+)/!) { $prefix .=$1; $pos = rindex($ENV{'PATH_TRANSLATED'},substr($ENV{'PATH_INFO'},length($1))); } if ($pos <0) { show_error({},"Ошибка конфигурации форума. Не удается определить алгоритм преобразования директори в URL\n". "PATH_INFO=$ENV{PATH_INFO}\n". "PATH_TRANSLATER=$ENV{'PATH_TRANSLATED'}"); } my $root = substr($ENV{'PATH_TRANSLATED'},0,$pos); if (substr($dir,0,length($root)) ne $root) { show_error({},"Ошибка конфигурации форума. Не удается преобразовать имя директории $dir в url\n". "PATH_INFO=$ENV{PATH_INFO}\n". "PATH_TRANSLATER=$ENV{'PATH_TRANSLATED'}"); } return $prefix.substr($dir,length($root)); } # # Поиск файла .forum вверх по дереву от $ENV{PATH_TRANSLATED} # Значение PATH_TRANSLATED считаем безопасным - наш web-сервер нам не # враг. # Возвращает список имя,значение, имя, значение который прививается в # хэш sub get_forum_config { my @path=split("/",$1) if $ENV{PATH_TRANSLATED}=~/^(\S+)$/; while (@path>1) { 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; # # Переменная forumtop - это URL того места, где находится # файл .forum $config{"forumtop"} = dir2url($cgi,join("/",@path)); # Если в конфиге отсутствует переменная templates, но # рядом с конфигом присутствует директория templates, # то шаблоны там. # if (! exists $config{"templates"} && -d (my $filename = join("/",@path,"templates"))) { $config{"templates"} = $filename; } $config{"templatesurl"} = dir2url($cgi,$config{"templates"}) unless exists $config{"templatesurl"}; # # То же самое - параметр userdir и директория users # if (! exists $config{"userdir"} && -d (my $filename = join("/",@path,"users"))) { $config{"userdir"} = $filename; } $config{"userurl"} = dir2url($cgi,$config{"userdir"}); # # Если нет ссылки в конфиге на файл паролей или он не # существует, выдаем ошибку. С офоромлением, так как шаблоны # у нас уже есть if (!exists $config{"datadir"}) { show_error(\%config,"В конфигурации форума не указана директория данных "); exit; } if (!-d $config{"datadir"}) { show_error(\%config,"В конфигурации форума указана несуществующая директория данных "); exit; } $config{"authperiod"}="+1M" if (! exists $config{"authperiod"}); $config{"renewtime"} = "86000" if (!exists $config{"renewtime"}); $config{"replies_per_page"} = 50 if (!exists $config{"replies_per_page"}); return \%config; } pop @path; } # # Выводим ошибку 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 $cgi->header(-type=>'text/html',-charset=>'utf-8'); print "Ошибка конфигурации форума", "

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

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

", "

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

"; } exit; } # # Вывод шаблона формы. В шаблоне должна присутстовать форма с # именем, совпадающим с именем form. Если в $cgi есть параметры, имена # которых совпадают с именами полей этой формы, их значения # подставляются # sub show_template { my ($form,$cgi,$forum) = @_; my $filename=$forum->{"templates"}."/$form.html"; if (! -r $filename) { show_error($forum,"Нет шаблона для операции $form"); exit; } my $tree = HTML::TreeBuilder->new_from_file($filename); fix_forum_links($forum,$tree); # Находим форму с классом $form my $f = $tree->look_down("_tag","form", "name",$form); if (! defined $f) { # Если не нашли - ругаемся show_error($forum,"Шаблон для операции $form не содержит формы с именем $form"); exit; } $cgi->delete('password'); 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); $cgi->param("user",$forum->{"authenticated"}{"user"}) if (!defined $cgi->param("user")) } my %substituted; ELEMENT: for my $element ($f->find_by_tag_name("textarea","input","select")) { my $name = $element->attr("name"); $substituted{$name} = 1; #print STDERR "substituting form element name $name tag ",$element->tag, # "value='",$cgi->param($name),"'\n"; if (defined $cgi->param($name)) { if ($element->tag eq "input") { next ELEMENT if grep ($element->attr("type") eq $_,"button","submit","reset"); if ($element->attr("type") eq "check") { if (grep($element->attr("value") eq $_,$cgi->param($name))) { $element->attr("checked",""); } else { $element->attr("checked",undef); } } elsif ($element->attr("type") eq "radio") { if ($element->attr("value") eq $cgi->param($name)) { $element->attr("checked",""); } else { $element->attr("checked",undef); } } else { $element->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"); 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 fix_forum_links { my ($forum,$tree,$path_info) = @_; $path_info=$ENV{'PATH_INFO'} if (!defined $path_info); my $script_with_path = $ENV{SCRIPT_NAME}.$path_info; ELEMENT: for my $element ($tree->find_by_tag_name("form","img","link","script","a")) { my $attr; if ($element->tag eq "form") { $attr = "action"; } elsif ($element->tag eq "a"|| $element->tag eq "link") { $attr = "href"; } else { $attr ="src"; } my $link = $element->attr($attr); print STDERR "Fixing link $link\n"; # Абсолютная ссылка - оставляем как есть. next ELEMENT if (! defined $link || $link=~/^\w+:/); # Ссылка от корня сайта. if (substr($link,0,1) eq "/") { # Если она не ведет на наш скрипт, не обрабатываем next ELEMENT if substr($link,0,length($ENV{SCRIPT_NAME}) ne $ENV{SCRIPT_NAME}) ; # Иначе пишем туда слово forum вместо реального имени # скрипта чтобы потом единообразно обработать $link =~ s/^[^\?]+/forum/; } if (!($link =~ s!^templates/!$forum->{templatesurl}/!) && !($link =~ s!^users/!$forum->{usersurl}/!) && !($link =~ s!^forum\b!$script_with_path!)) { $link = $forum->{"forumtop"}."/".$link } print STDERR "Fixed to $link\n"; $element->attr($attr,$link); } } # # Подставляет в заданное поддерево информацию о пользователе # 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) { my $userpage; if ($userinfo{"user"}=~/^http:/) { $userpage = $userinfo{"user"}; } else { $userpage = $cgi->url(-absolute=>1,-path_info=>1)."?profile=1&user=".$cgi->escape($userinfo{"user"}); } for my $element (@userlink) { $element->attr(href=>$userpage); $element->delete_content(); $element->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,datafile($forum,"session"),0644; if ($sessbase{$session}) { my ($user,$expires,$ip)=split(";", $sessbase{$session}); if (!defined $ip|| $ip eq $ENV{'REMOTE_ADDR'}) { my %userbase; dbmopen %userbase,datafile($forum,"passwd"),0644; if ( $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); } print STDERR "user $user restored session $session\n"; $forum->{"authenticated"}=$userinfo; print STDERR "authorize_user: ",$forum->{authenticated}{user}, $forum->{authenticated},"\n"; } dbmclose %userbase; } } dbmclose %sessbase; } } # # Возвращает путь к файлу в директории # sub datafile { my ($forum,$filename) = @_; return $forum->{"datadir"}."/".$filename; } # # Создает новую сессию для пользователя и подготавливает куку которую # сохраняет в хэше конфигурации форума # sub newsession { my ($base,$forum,$user,$bindip) = @_; if (!defined $base) { $base = {}; dbmopen %$base,datafile($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->{'cookies'}=[ $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,datafile($forum,"passwd"),0644; my $user = $cgi->param("user"); my $password = $cgi->param("password"); print STDERR "user=>'$user'\npassword=>'$password'\n"; $cgi->delete("password"); if (! $userbase{$user}) { set_error($forum,"Неверное имя пользователя или пароль"); return undef; } my $userinfo = thaw($userbase{$user}) ; dbmclose %userbase; while (my ($key,$val)=each %$userinfo) { print STDERR "$key => '$val'\n";} if (crypt($password,$userinfo->{passwd}) eq $userinfo->{passwd}) { delete $userinfo->{"passwd"}; $cgi->delete("password"); $userinfo->{"user"} = $user; newsession(undef,$forum,$user); $forum->{"authenticated"} = $userinfo; print STDERR "User $user authenticated successfully\n"; return 1; } else { set_error($forum,"Неверное имя пользователя или пароль"); return undef; } } # # Запоминает сообщение об ошибке для последующего вывода show_template # sub set_error { my ($forum,$message) = @_; print STDERR "set_error: $message\n"; $forum->{error_message} = $message; } # # Выводит текущий шаблон с сообщением об ошибке # sub form_error { my ($form_name,$cgi,$forum,$msg) = @_; set_error($forum,$msg); show_template($form_name,$cgi,$forum); exit; } # # Выполняет редирект (возможно, с установкой куков) на страницу, # указанную # третьем параметре функции или в параметре CGI-запроса # returnto # Если и то, и другое не определено, пытается сконструировать URL для # возврата из PATH_INFO. # sub forum_redirect { my ($cgi,$forum,$url) = @_; if (!defined $url) { $url = $cgi->param("returnto"); $url = $cgi->url(-base=>1).$cgi->path_info() if (!$url); } print $cgi->redirect(-url=>$url, ($forum->{cookies}?(-cookie=>$forum->{cookies}):())); 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,datafile($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 "stilllife forum: registering user $user\n"; $userbase{$user} = freeze($userinfo); dbmclose %userbase; newsession(undef,$forum,$user); forum_redirect($cgi,$forum,$returnto) } # # Обработчик формы логина. Сводится к вызову функции authenticate, # поскольку мы поддерживаем логин одновременный с отправкой реплики. # sub login { my ($form,$cgi,$forum)=@_; if (authenticate($cgi,$forum)) { forum_redirect($cgi,$forum); } else { show_template(@_); } } # # Обработчик формы logout. В отличие от большинства обработчиков форм, # поддерживает обработку методом GET # sub logout { my ($form,$cgi,$forum) = @_; $forum->{cookies}=[ $cgi->cookie(-name=>"sluser", -value=>"0", -expires=>"-1m"),$cgi->cookie(-name=>"slsession", -value=>"0", -expires => "-1m")]; if (defined (my $session_id = $cgi->cookie("slsession"))) { my %sessiondb; dbmopen %sessiondb,datafile($forum,"session"),0644; delete $sessiondb{$session_id}; dbmclose %sessiondb; } forum_redirect($cgi,$forum); } sub allow_operation { my ($operation,$cgi,$forum) = @_; return 1 if (grep $operation eq $_,"register","login","reply"); return 1; } sub reply { my ($form,$cgi,$forum) = @_; if (! exists $forum->{authenticated} ) { form_error($form,$cgi,$forum,"Вы не зарегистрировались") if (!authenticate($cgi,$forum)); } # # Находим файл дискуссии, в который надо поместить реплику # # # Сохраняем приаттаченную картинку, если есть. # # Генерируем идентификатор записи. # # # Преобразуем текст записи в html и чистим его # my $txtree = undef; if ($cgi->param("format") eq "bbcode") { } elsif ($cgi->param("format") eq "text") { my $text = $cgi->escapeHTML($cgi->param("text")); $text=~s/\r?\n\r?\n/

/; $text=~s/\n/
/; $txtree = HTML::TreeBuilder->new_from_content("

$text
"); } else { # Default - html $txtree = HTML::TreeBuilder->new_from_content("
".$cgi->param("text")."
"); for my $badtag ("script","style","head","html","object","embed","iframe","frameset","frame", ($forum->{forbid_tags}?split(/\s*,\s*/,$forum->{forbid_tags}):())) { for my $element ($txtree->find_by_tag_name($badtag)) { $element->delete() if defined $element; } } } }