forum/forum

   1 #!/usr/bin/perl -T
   2 #
   3 # Stil Life forum. Copyright (c) by Victor B. Wagner, 2008
   4 # This program distributed under GNU Affero General Public License v3 or
   5 # above
   6 # http://www.gnu.org/licenses/agpl.html
   7 #
   8 # Вкратце: Если вы используете этот скрипт на своем сайте, Вы обязаны
   9 # сделать доступным его исходный текст. В частности, если Вы внесли
  10 # какие-либо изменения, вы должны эти изменения опубликовать.
  11 #
  12 # Home site of this program http://vitus.wagner.pp.ru/stilllife
  13 #
  14 use strict;
  15 use warnings;
  16 use Fcntl qw(:DEFAULT :flock);
  17 use CGI;
  18 use HTML::TreeBuilder;
  19 use Storable qw(freeze thaw);
  20 use Date::Parse;
  21 use Email::Valid;
  22 use Image::Size;
  23 use HTML::BBReverse;
  24 use POSIX;
  25 use LWP::UserAgent;
  26 use Net::OpenID::Consumer;
  27 #
  28 # Набор поддерживаемых действий. Хэш вида
  29 # "имя поля в запросе" =>  "функция обработчик"
  30 #
  31 my %actions = (
  32         reply => \&reply,
  33         edit => \&edit_comment,
  34         delete => \&delete_comment,
  35         move => \&move_comment,
  36         newtopic=> \&new_topic,
  37         newforum=> \&new_forum,
  38         login => \&login,
  39         register=>\&register,
  40         profile=>\&profile,
  41         setrights=>\&set_rights,
  42         openidlogin=>\&openid_login,
  43         openidvfy =>\&openid_verify
  44 );
  45 #
  46 #  Уровень прав, которые необходимо иметь пользователю для совершения
  47 #  определенного действия
  48 #  иерархия вида undef < banned < normal < author < moderator <admin
  49 #  Если операция не упомянута в данном массив, то значит можно всем, в
  50 #  том числе  и анониму.
  51 # Слово login означает, что вообще-то это normal, но пользователь может
  52 # логиниться непосредственно в процессе выполнения операции.
  53 my %permissions = (
  54         reply => "login",
  55         edit => "author",
  56         delete => "author",
  57         newtopic => "normal",
  58         move => "moderator",
  59         newforum => "moderator",
  60         profile => "normal",
  61         setrights => "admin",
  62 );
  63 our $path_translated; # Untainted value of PATH_TRANSLATED env var
  64 my $cgi = new CGI;
  65 print STDERR "--------------------\n";
  66 my $forum=get_forum_config();
  67
  68 authorize_user($cgi,$forum);
  69 if ($cgi->request_method ne "POST") {
  70 # Запрос к скрипту методом GET. Надо показать форму, если только это не
  71 # редирект от OpenId-сервера
  72         if ($cgi->param('openidvfy')) {
  73                 openid_verify($cgi,$forum);
  74         } elsif ($cgi->param("logout")) {
  75                 logout('logout',$cgi,$forum);
  76         } else {
  77                 for my $param ($cgi->param) {
  78 # Среди параметров, указанных в URL ищем тот, который задает
  79 # действие
  80                         if (exists $actions{$param}) {
  81 # Мы, конечно уже проверили, что в названии параметра
  82 # нехороших символов нет, но чтобы perl в taint mode не
  83 # ругался...
  84                                 if (allow_operation($param,$cgi,$forum)) {
  85                                         print STDERR "Allow_operation completed\n";
  86                                         show_template($1,$cgi,$forum) if $param=~/^(\w+)$/;
  87                                         exit;
  88                                 } else {
  89                                         if (!$forum->{"authenticated"}) {
  90                                                 $cgi->param("returnto",$cgi->url(-full=>1));
  91                                                 show_template("login",$cgi,$forum);
  92                                                 exit;
  93
  94                                         } else {
  95                                                 show_error($forum,"У Вас нет прав на  выполнение этой
  96                                                 операции")
  97                                         }
  98                                 }
  99                         }
 100                 }
 101                 show_error($forum,"Некорректный вызов скрипта. Отсутствует параметр
 102                                 действия");
 103         }
 104 } else {
 105         # Запрос методом POST. Вызываем обработчик
 106         for my $param ($cgi->param) {
 107                 if (exists $actions{$param}) {
 108                         if (allow_operation($param,$cgi,$forum)) {
 109                                 $actions{$param}->($param,$cgi,$forum);
 110                                 exit;
 111                         } else {
 112                                 show_error($forum,"У Вас нет прав на  выполнение этой
 113                                 операции")
 114                         }
 115
 116                 }
 117         }
 118         print STDERR "Получены параметры ",join(" ",$cgi->param),"\n";
 119         show_error($forum,"Некорректный вызов скрипта. Отсутствует параметр действия");
 120 }
 121
 122 sub dir2url {
 123         my ($cgi,$dir) = @_;
 124         my $prefix="";
 125         my $pos=rindex $ENV{'PATH_TRANSLATED'},$ENV{'PATH_INFO'};
 126         if ($pos <0 && $ENV{'PATH_INFO'}=~m!(/\~\w+)/!) {
 127                 $prefix .=$1;
 128                 $pos =
 129                 rindex($ENV{'PATH_TRANSLATED'},substr($ENV{'PATH_INFO'},length($1)));
 130         }
 131         if ($pos <0) {
 132                 show_error({},"Ошибка конфигурации форума. Не удается определить
 133                 алгоритм преобразования директори в URL\n".
 134                 "PATH_INFO=$ENV{PATH_INFO}\n".
 135                 "PATH_TRANSLATER=$ENV{'PATH_TRANSLATED'}");
 136         }
 137         my $root = substr($ENV{'PATH_TRANSLATED'},0,$pos);
 138         if (substr($dir,0,length($root)) ne $root) {
 139                 show_error({},"Ошибка конфигурации форума. Не удается преобразовать
 140                 имя директории $dir в url\n".
 141                 "PATH_INFO=$ENV{PATH_INFO}\n".
 142                 "PATH_TRANSLATER=$ENV{'PATH_TRANSLATED'}");
 143         }
 144         return $prefix.substr($dir,length($root));
 145 }
 146 #
 147 # Поиск файла .forum вверх по дереву от $path_translated
 148 # Значение PATH_TRANSLATED считаем безопасным - наш web-сервер нам не
 149 # враг.
 150 # Возвращает список имя,значение, имя, значение который прививается в
 151 # хэш
 152
 153 sub get_forum_config {
 154         $path_translated = $1 if $ENV{PATH_TRANSLATED}=~/^(\S+)$/;
 155         $path_translated=~s/\/+$//;
 156         my @path=split("/",$path_translated);
 157         while (@path>1) {
 158                 if (-r (my $config=join("/",@path,".forum")) ) {
 159                         open F,"<",$config;
 160                         my %config;
 161                         while (<F>) {
 162                                 s/#.*$//; #Drop comments;
 163                                 $config{$1}=$2 if /(\w+)\s*=\s*(\S.*)$/;
 164                         }
 165                         close F;
 166                         #
 167                         # Переменная forumtop - это URL того места, где находится
 168                         # файл .forum
 169
 170                         $config{"forumtop"} = dir2url($cgi,join("/",@path));
 171                         # Если в конфиге отсутствует переменная templates, но
 172                         # рядом с конфигом присутствует директория templates,
 173                         # то шаблоны там.
 174                         #
 175                         if (! exists $config{"templates"}
 176                                 && -d (my $filename = join("/",@path,"templates"))) {
 177                                         $config{"templates"} = $filename;
 178                         }
 179                         $config{"templatesurl"} = dir2url($cgi,$config{"templates"})
 180                                 unless exists $config{"templatesurl"};
 181                         #
 182                         # То же самое - параметр userdir и директория users
 183                         #
 184                         if (! exists $config{"userdir"}
 185                                 && -d (my $filename = join("/",@path,"users"))) {
 186                                         $config{"userdir"} = $filename;
 187
 188
 189                         }
 190                         $config{"userurl"} = dir2url($cgi,$config{"userdir"});
 191                         #
 192                         # Если нет ссылки в конфиге на файл паролей или он не
 193                         # существует, выдаем ошибку. С офоромлением, так как шаблоны
 194                         #  у нас уже есть
 195                         if (!exists $config{"datadir"}) {
 196                                 show_error(\%config,"В конфигурации форума не указана
 197                                 директория данных ");
 198                                 exit;
 199                         }
 200                         if (!-d $config{"datadir"}) {
 201                                 show_error(\%config,"В конфигурации форума указана несуществующая директория данных ");
 202                                 exit;
 203                         }
 204                         $config{"authperiod"}="+1M" if (! exists $config{"authperiod"});
 205                         $config{"renewtime"} = "86000" if (!exists $config{"renewtime"});
 206                         $config{"replies_per_page"} = 50 if (!exists $config{"replies_per_page"});
 207                         $config{"indexfile"} = "index.html" if (!exists $config{"indexfile"});
 208                         return \%config;
 209                 }
 210                 pop @path;
 211         }
 212         #
 213         # Выводим ошибку 404 без осмысленного оформления, так как данных форума
 214         # мы не нашли
 215         print "Status: 404\nContent-Type: text/html; charset=utf-8\n\n",
 216         "<HTML><HEAD><TITLE>Форум не обнаружен</TITLE></HEAD><BODY>",
 217         "<H!>Форум не найден</H!>",
 218         "<p>Хвост URL, указанный при вызове скрипта  показывает не на
 219         форум</p>",
 220         # To make IE think this page is user friendly
 221         "<!--",("X" x 512),"--></body></html>\n";
 222         exit;
 223 }
 224 #
 225 # Вывод сообщения об ошибке по шаблону форума
 226 # Шаблон должен содержать элемент с классом error.
 227 #
 228 sub show_error {
 229         my ($cfg,$msg) = @_;
 230         if ( -r $cfg->{"templates"}."/error.html") {
 231                 my $tree = HTML::TreeBuilder->new_from_file($cfg->{"templates"}."/error.html");
 232                 my $node= $tree->find_by_attribute('class','error');
 233                 my $body;
 234                 if (!$node) {
 235                         $body = $tree->find_by_tagname('body');
 236                         $body->push_content($node = new
 237                         HTML::Element('div','class'=>'error'));
 238                 }
 239                 $node->delete_content;
 240                 $node->push_content($msg);
 241                 print $cgi->header(-type=>'text/html',-charset=>'utf-8');
 242                 print $tree->as_HTML("<>&");
 243         } else {
 244                 print $cgi->header(-type=>'text/html',-charset=>'utf-8');
 245                 print "<html><head><title>Ошибка конфигурации форума</title></head>",
 246                 "<body><h1>Ошибка конфигурации форума</h1><p>",
 247                 $cgi->escapeHTML($msg),"</p>",
 248                 "<p>При обработке этой ошибки не обнаружен шаблон сообщения об ошибке</p></body></html>";
 249         }
 250         exit;
 251 }
 252
 253 #
 254 # Вывод шаблона формы. В шаблоне должна присутстовать форма с
 255 # именем, совпадающим с именем form. Если в $cgi есть параметры, имена
 256 # которых совпадают с именами полей этой формы, их значения
 257 # подставляются
 258 #
 259 sub show_template {
 260         my ($form,$cgi,$forum) = @_;
 261         my $tree = gettemplate($forum,$form,$ENV{'PATH_INFO'});
 262
 263         # Находим форму с классом $form
 264         my $f = $tree->look_down("_tag","form",
 265                 "name",$form);
 266         if (! defined $f) {
 267                 # Если не нашли - ругаемся
 268                 show_error($forum,"Шаблон для операции $form не содержит формы с
 269                 именем $form");
 270                 exit;
 271         }
 272         $cgi->delete('password');
 273         if (!$cgi->param("returnto")) {
 274                 $cgi->param("returnto", $cgi->referer||$cgi->url(-absolute=>1,-path_info=>1));
 275
 276         }
 277         if (!$cgi->param($form)) {
 278                 $cgi->param($form,1);
 279         }
 280         #
 281         # Если ранее была выставлена ошибка с помощью set_error, подставляем
 282         # сообщение в элемент с классом error
 283         #
 284         if ($forum->{error_message}) {
 285                 my $errormsg = $tree->look_down("class"=>"error");
 286                 if ($errormsg) {
 287                         $errormsg->delete_content();
 288                         $errormsg->push_content($forum->{error_message});
 289                 }
 290         }
 291         if ($forum->{"authenticated"}) {
 292
 293                 # Подставляем информацию о текущем пользователе если в шаблоне
 294                 # это предусмотрено
 295                 substitute_user_info($tree,$forum);
 296                 $cgi->param("user",$forum->{"authenticated"}{"user"}) if (!defined $cgi->param("user"))
 297         }
 298         my %substituted;
 299         ELEMENT:
 300         for my $element ($f->find_by_tag_name("textarea","input","select")) {
 301                 my $name = $element->attr("name");
 302                 $substituted{$name} = 1;
 303                 #print STDERR "substituting form element name $name tag ",$element->tag,
 304             #           "value='",$cgi->param($name),"'\n";
 305                 if (defined  $cgi->param($name)) {
 306                         if ($element->tag eq "input") {
 307                                 next ELEMENT if grep ($element->attr("type") eq
 308                                 $_,"button","submit","reset");
 309                                 if ($element->attr("type") eq "check") {
 310                                         if (grep($element->attr("value") eq $_,$cgi->param($name))) {
 311                                                 $element->attr("checked","");
 312                                         } else {
 313                                                 $element->attr("checked",undef);
 314                                         }
 315
 316                                 } elsif ($element->attr("type") eq
 317                                 "radio") {
 318                                         if ($element->attr("value") eq $cgi->param($name)) {
 319                                                 $element->attr("checked","");
 320                                         } else {
 321                                                 $element->attr("checked",undef);
 322                                         }
 323                                 } else {
 324                                 $element->attr("value",$cgi->param($name));
 325                                 }
 326                         } elsif ($element->tag eq "textarea") {
 327                                 $element->delete_content;
 328                                 $element->push_content($cgi->param($name));
 329                         } elsif ($element->tag eq "select") {
 330                                 for my $option ($element->find_by_tag_name("option")) {
 331                                         if (grep($option->attr("value") eq $_, $cgi->param($name))) {
 332                                                 $option->attr("selected","");
 333                                         } else {
 334                                                 $option->attr("selected",undef);
 335                                         }
 336                                 }
 337
 338                         }
 339                 }
 340
 341         }
 342         $f->attr("method","POST");
 343         for my $required ($form,"returnto") {
 344                 if (!$substituted{$required}) {
 345                         my $element = new HTML::Element('input',
 346                                 'type' => 'hidden', 'name' => $required,
 347                                 'value'=> $cgi->param($required));
 348                         $f->push_content($element);
 349                 }
 350         }
 351
 352
 353         print
 354         $cgi->header(-type=>"text/html",-charset=>"utf-8",($forum->{cookies}?(-cookie=>$forum->{cookies}):())),
 355         $tree->as_HTML("<>&");
 356 }
 357 #
 358 # Поправляет ссылки на служебные файлы и скрипты форума
 359 #
 360 sub fix_forum_links {
 361         my ($forum,$tree,$path_info) = @_;
 362         if (!defined $path_info) {
 363                 $path_info = $ENV{PATH_INFO};
 364                 $path_info =~ s/\/+/\//g;
 365         }
 366         my $script_with_path = $ENV{SCRIPT_NAME}.$path_info;
 367         ELEMENT:
 368         for my $element ($tree->find_by_tag_name("form","img","link","script","a")) {
 369                 my $attr;
 370                 if ($element->tag eq "form")  {
 371                         $attr = "action";
 372                 } elsif ($element->tag eq "a"|| $element->tag eq "link") {
 373                         $attr = "href";
 374                 } else {
 375                         $attr ="src";
 376                 }
 377
 378                 # Обрабатываем наши специальные link rel=""
 379                 if ($element->tag eq "link") {
 380                         if ($element->attr("rel") eq "forum-user-list") {
 381                                 $element->attr("href" => $cgi->url(-absolute=>1,
 382                                         -path_info=>0,-query_string=>0).$forum->{userurl});
 383                                 next ELEMENT;
 384                         } elsif ($element->attr("rel") eq "forum-script")  {
 385                                 $element->attr("href" => $script_with_path);
 386                                 next ELEMENT;
 387                         }
 388                 }
 389                 my $link = $element->attr($attr);
 390                 # Абсолютная ссылка - оставляем как есть.
 391                 next ELEMENT if (! defined $link || $link=~/^\w+:/ || $link
 392                 eq"."||$link eq "..");
 393                 # Ссылка от корня сайта.
 394                 if (substr($link,0,1) eq "/") {
 395                         # Если она не ведет на наш скрипт, не обрабатываем
 396                         next ELEMENT if substr($link,0,length($ENV{SCRIPT_NAME}) ne
 397                         $ENV{SCRIPT_NAME}) ;
 398                         # Иначе пишем туда слово forum вместо реального имени
 399                         # скрипта чтобы потом единообразно обработать
 400                         $link =~ s/^[^\?]+/forum/;
 401                 }
 402                 if (!($link =~ s!^templates/!$forum->{templatesurl}/!) &&
 403                     !($link =~ s!^users/!$forum->{usersurl}/!) &&
 404                     !($link =~ s!^forum\b!$script_with_path!)) {
 405                         $link = $forum->{"forumtop"}."/".$link
 406                 }
 407                 $element->attr($attr,$link);
 408         }
 409 }
 410 #
 411 # Подставляет в заданное поддерево информацию о пользователе
 412 #
 413
 414 sub substitute_user_info {
 415
 416 my ($tree,$forum,$user) = @_;
 417 my %userinfo;
 418 if (defined $user) {
 419         my %users;
 420         dbmopen %users,datafile($forum,"passwd"),0644;
 421         if (!$users{$user}) {
 422                 show_error($forum,"Неизвестный пользователь $user");
 423         }
 424         my $record = thaw($users{$user});
 425         %userinfo = %$record;
 426         $userinfo{"user"} = $user;
 427 } else {
 428         # Если не сказано, какой юзер, то текущий.
 429         %userinfo = %{$forum->{"authenticated"}}
 430 }
 431
 432 #
 433 # Специально обрабатываем поля user (должна быть ссылка) и avatar
 434 # (должен быть img).
 435         my $userpage;
 436         if ($userinfo{"openiduser"}) {
 437                 $userpage = "http://".$userinfo{"user"};
 438         } else {
 439                 $userpage =
 440                 $cgi->url(-absolute=>1).$forum->{"userurl"}."/".$cgi->escape($userinfo{"user"});
 441         }
 442         substinfo($tree,["_tag"=>"a","class"=>"author"],
 443          href=>$userpage,_content=>$userinfo{"user"});
 444         delete $userinfo{"user"};
 445         if (ref $userinfo{"avatar"} eq "HASH") {
 446                 substinfo($tree,["_tag"=>"img","class"=>"avatar"],
 447                 %{$userinfo{'avatar'}});
 448         } elsif ($userinfo{'avatar'})  {
 449                 substinfo($tree,["_tag"=>"img","class"=>"avatar"],
 450                 src=>$userinfo{"avatar"});
 451         } else {
 452                 substinfo($tree,["_tag"=>"img","class"=>"avatar"],
 453                         src=>$forum->{templatesurl}."/1x1.gif",
 454                         width=>1,height=>1);
 455         }
 456         delete $userinfo{"avatar"};
 457
 458         for my $element ( $tree->look_down("class",qr/^ap-/)) {
 459                 my $field=$1 if $element->attr("class")=~/^ap-(.*)$/;
 460                 $element->delete_content();
 461                 $element->push_content(str2tree($userinfo{$field}))
 462                                 if $userinfo{$field};
 463                 $element->attr(href=>"mailto:$userinfo{$field}")
 464                         if ($element->tag eq "a" && $field eq "email");
 465         }
 466
 467
 468 }
 469 #
 470 # Авторизует зарегистрированного пользователя.
 471 # 1. Проверяет куку если есть
 472 #
 473
 474 sub authorize_user      {
 475         ($cgi,$forum) = @_;
 476         if (my $session=$cgi->cookie("slsession")) {
 477         # Пользователь имеет куку
 478                 my %sessbase;
 479                 dbmopen %sessbase,datafile($forum,"session"),0644;
 480                         if ($sessbase{$session})  {
 481                                 my ($user,$expires,$ip)=split(";", $sessbase{$session});
 482                                 my $user_cookie = $cgi->cookie("sluser");
 483                                 if ($user_cookie ne $user && $user_cookie ne
 484                                 "http://".$user) {
 485                                         clear_user_cookies($cgi,$forum);
 486                                         show_error($forum,"Некорректная пользовательская сессия");
 487                                         exit;
 488                                 }
 489                                 if (!defined $ip|| $ip eq $ENV{'REMOTE_ADDR'}) {
 490                                         my %userbase;
 491                                         dbmopen %userbase,datafile($forum,"passwd"),0644;
 492                                         if ( $userbase{$user}) {
 493                                                 print STDERR "getting user info for $user\n";
 494                                                 my $userinfo = thaw($userbase{$user});
 495                                                 delete $userinfo->{"passwd"};
 496                                                 $userinfo->{"user"} = $user;
 497                                                 if ($expires-time()< $forum->{"renewtime" }) {
 498                                                         delete $sessbase{$session};
 499                                                         newsession(\%sessbase,$forum,$user,$ip);
 500                                                 }
 501                                                 print STDERR "user $user restored session $session\n";
 502                                                 $forum->{"authenticated"}=$userinfo;
 503                                                 print STDERR "authorize_user: ",$forum->{authenticated}{user},
 504                                                 $forum->{authenticated},"\n";
 505                                         }
 506                                         dbmclose %userbase;
 507                                 }
 508                         } else {
 509                                 clear_user_cookies($cgi,$forum);
 510                                 show_error($forum,"Некорректная пользовательская сессия");
 511                                 exit;
 512                         }
 513                 dbmclose %sessbase;
 514         }
 515 }
 516 #
 517 # Возвращает путь к файлу в директории
 518 #
 519 sub datafile {
 520         my ($forum,$filename) = @_;
 521         return $forum->{"datadir"}."/".$filename;
 522 }
 523
 524 #
 525 # Создает новую сессию для пользователя и подготавливает куку которую
 526 # сохраняет в хэше конфигурации форума
 527 #
 528 sub newsession {
 529         my ($base,$forum,$user,$bindip) = @_;
 530         if (!defined $base) {
 531                 $base = {};
 532                 dbmopen %$base,datafile($forum,"session"),0644;
 533         }
 534         my $sessname;
 535         my $t = time();
 536         my ($u,$expires,$ip);
 537         do {
 538                 $sessname = sprintf("%08x",rand(0xffffffff));
 539                 if ($base->{"sessname"}) {
 540                         ($u,$expires,$ip) = split ";", $base->{$sessname};
 541                         delete $base->{$sessname} if $expires < $t;
 542                 }
 543         } while ($base->{$sessname});
 544         my $cookie = $cgi->cookie(-name=>"slsession",
 545                 -expires => $forum->{"authperiod"},-value=> $sessname);
 546         my $username = $user;
 547         $username =~ s/^http:\/\///; #Remoove http:// from OpenID user names
 548         $base->{$sessname}=$username.";".str2time($cookie->expires()).
 549                 ($ip?";$ENV{'REMOTE_ADDR'}":"");
 550
 551         $forum->{'cookies'}=[ $cookie,
 552         $cgi->cookie(-name=>"sluser",-value=>$user,-expires =>
 553         $forum->{authperiod})];
 554 }
 555 #
 556 # Выполняет аутентикацию пользователя по логину и паролю и
 557 # создает для него сессию.
 558 #
 559 sub authenticate {
 560         my ($cgi,$forum) = @_;
 561         if ($cgi->param("openidsite")) {
 562                 my $openid_url = sprintf($cgi->param("openidsite"),$cgi->param("user"));
 563                 openidstart($cgi,$forum,$openid_url);
 564         }
 565         my %userbase;
 566         dbmopen %userbase,datafile($forum,"passwd"),0644;
 567         my $user = $cgi->param("user");
 568         my $password = $cgi->param("password");
 569         $cgi->delete("password");
 570         if (! $userbase{$user}) {
 571           set_error($forum,"Неверное имя пользователя или пароль");
 572           return undef;
 573         }
 574         my $userinfo = thaw($userbase{$user}) ;
 575         dbmclose %userbase;
 576         #while (my ($key,$val)=each %$userinfo) { print STDERR "$key => '$val'\n";}
 577         if (crypt($password,$userinfo->{passwd}) eq $userinfo->{passwd}) {
 578                 delete $userinfo->{"passwd"};
 579                 $cgi->delete("password");
 580                 $userinfo->{"user"} = $user;
 581                 newsession(undef,$forum,$user);
 582                 $forum->{"authenticated"} = $userinfo;
 583                 print STDERR "User $user authenticated successfully\n";
 584                 return 1;
 585         } else {
 586                 set_error($forum,"Неверное имя пользователя или пароль");
 587                 return undef;
 588         }
 589 }
 590 #
 591 # Запоминает сообщение об ошибке для последующего вывода show_template
 592 #
 593 sub set_error {
 594         my  ($forum,$message) = @_;
 595         print STDERR "set_error: $message\n";
 596         $forum->{error_message} = $message;
 597 }
 598 #
 599 # Выводит текущий шаблон с сообщением об ошибке
 600 #
 601 sub form_error {
 602         my ($form_name,$cgi,$forum,$msg) = @_;
 603         set_error($forum,$msg);
 604         show_template($form_name,$cgi,$forum);
 605         exit;
 606 }
 607 #
 608 # Выполняет редирект (возможно, с установкой куков) на страницу,
 609 # указанную # третьем параметре функции или в параметре CGI-запроса
 610 # returnto
 611 # Если и то, и другое не определено, пытается сконструировать URL для
 612 # возврата из PATH_INFO.
 613 #
 614
 615 sub forum_redirect {
 616         my ($cgi,$forum,$url) = @_;
 617         if (!defined $url) {
 618                 $url = $cgi->param("returnto");
 619                 $url =
 620                 $cgi->url(-base=>1).($cgi->path_info()||$forum->{forumtop}) if !$url ;
 621         }
 622         print $cgi->redirect(-url=>$url,
 623                 ($forum->{cookies}?(-cookie=>$forum->{cookies}):()));
 624         exit;
 625 }
 626 #
 627 # Обработка результатов заполнения формы регистрации.
 628 #
 629 #
 630 sub register {
 631         my ($formname,$cgi,$forum) = @_;
 632         #
 633         # Возможные ошибки:
 634         # 1 Такой юзер уже есть
 635         #
 636         #  не заполнено поле user
 637         if (!$cgi->param("user")) {
 638                 form_error($formname,$cgi,$forum, "Не заполнено имя пользователя");
 639         }
 640         #  или поле password
 641         if (!$cgi->param("pass1"))  {
 642                 form_error($formname,$cgi,$forum,"Не указан пароль");
 643         }
 644         #  Копии пароля не совпали
 645         if ($cgi->param("pass2") ne $cgi->param("pass1")) {
 646                 form_error($formname,$cgi,$forum,"Ошибка при вводе пароля");
 647         }
 648         my $user = $cgi->param("user");
 649         # Не указаны поля, перечисленные в скрытом поле required
 650         if ($cgi->param("required")) {
 651                 foreach my $field (split(/\s*,\s*/,$cgi->param('required'))) {
 652                         if (!$cgi->param($field)) {
 653                                 form_error($formname,$cgi,$forum,"Не заполнено обязательное поле $field");
 654                         }
 655                 }
 656         }
 657         my %userbase;
 658         dbmopen %userbase,datafile($forum,"passwd"),0644
 659                 or form_error($formname,$cgi,$forum,"Ошибка открытия файла паролей $!");
 660         if ($userbase{$cgi->param("user")}) {
 661                 dbmclose %userbase;
 662                 form_error($formname,$cgi,$forum,"Имя пользователя '".$cgi->param("user"). "' уже занято");
 663         }
 664         if ($cgi->param("email") && !  Email::Valid->address($cgi->param("email"))) {
 665                 form_error($formname,$cgi,$forum,"Некорректный E-Mail адрес");
 666         }
 667         my $saltstring = 'ABCDEFGHIJKLMNOPQRSTUVWXUZabcdefghijklmnopqrstuvwxuz0123456789./';
 668         my $salt = substr($saltstring,int(rand(64)),1).
 669                                 substr($saltstring,int(rand(64)),1);
 670         my $password=crypt($cgi->param("pass1"),$salt);
 671         my $userinfo = {passwd=>$password};
 672         # Удаляем лишние поля
 673         $cgi->delete("required");
 674         $cgi->delete("register");
 675         $cgi->delete("user");
 676         $cgi->delete("pass1");
 677         $cgi->delete("pass2");
 678         foreach my $field (split(/\s*,\s*/,$cgi->param('ignore'))) {
 679                 if (!$cgi->param($field)) {
 680                         $cgi->delete($field);
 681                 }
 682         }
 683         my $returnto = $cgi->param("returnto");
 684         $cgi->delete("returnto");
 685         # Если есть аватар в файле, то сохраняем этот файл и формируем URL
 686         # на него.
 687         if ($cgi->param("avatarfile" )) {
 688                 my $f = $cgi->upload("avatarfile");
 689                 binmode $f,":bytes";
 690                 my $out;
 691                 my $filename = $1 if $cgi->param("avatarfile")=~/([^\/\\]+)$/;
 692                 open $out,">",$forum->{"userdir"}."/".$filename;
 693                 binmode $out,":bytes";
 694                 my $buffer;
 695                 while (my $bytes = read($f,$buffer,4096)) {
 696                         print $out $buffer;
 697                 }
 698                 close $f;
 699                 close $out;
 700                 $userinfo->{'avatar'}= $forum->{"userurl"}."/".$filename;
 701                 $cgi->delete("avatar");
 702                 $cgi->delete("avatarfile");
 703         }
 704
 705         foreach my $param       ($cgi->param) {
 706                 $userinfo->{$param} = $cgi->param($param);
 707         }
 708         $userinfo->{registered} = time;
 709         if (exists $forum->{default_status}) {
 710                 $userinfo->{status} = $forum->{default_status};
 711         }
 712         print STDERR "stilllife forum: registering user $user\n";
 713         $userbase{$user} = freeze($userinfo);
 714         dbmclose %userbase;
 715         newsession(undef,$forum,$user);
 716         forum_redirect($cgi,$forum,$returnto)
 717 }
 718 sub clear_user_cookies {
 719         my ($cgi,$forum) = @_;
 720         $forum->{cookies}=[ $cgi->cookie(-name=>"sluser", -value=>"0",
 721         -expires=>"-1m"),$cgi->cookie(-name=>"slsession", -value=>"0",
 722                         -expires => "-1m")];
 723 }
 724 #
 725 # Обработчик формы логина. Сводится к вызову функции authenticate,
 726 # поскольку мы поддерживаем логин одновременный с отправкой реплики.
 727 #
 728 sub login {
 729         my ($form,$cgi,$forum)=@_;
 730         if (authenticate($cgi,$forum)) {
 731                 forum_redirect($cgi,$forum);
 732         } else {
 733                 show_template(@_);
 734         }
 735 }
 736 #
 737 # Обработчик формы logout. В отличие от большинства обработчиков форм,
 738 # поддерживает обработку методом GET
 739 #
 740 sub logout {
 741         my ($form,$cgi,$forum) = @_;
 742         clear_user_cookies($cgi,$forum);
 743         if (defined (my $session_id = $cgi->cookie("slsession"))) {
 744                 my %sessiondb;
 745                 dbmopen %sessiondb,datafile($forum,"session"),0644;
 746                 delete $sessiondb{$session_id};
 747                 dbmclose %sessiondb;
 748         }
 749         forum_redirect($cgi,$forum);
 750 }
 751 sub allow_operation {
 752         my ($operation,$cgi,$forum) = @_;
 753         return 1 if (!exists($permissions{$operation}));
 754         if (!$forum->{authenticated}) {
 755                 return 1 if ($permissions{$operation} eq "login");
 756                 return 0;
 757         }
 758         my $user = $forum->{authenticated}{user} ;
 759         my $accesslevel=getrights($cgi,$forum);
 760         # Если permissions{$operation} равны author, нам нужно извлечь
 761         # текст из соответствующего файла и положить его в
 762         # cgi->param("text"); Заодно определим и автора
 763         my ($itemauthor,$itemtext)=get_message_by_id($cgi->param("id")) if
 764                 $permissions{$operation} eq "author";
 765
 766         return 1 if ($accesslevel eq "admin");
 767         return 0 if ($permissions{$operation} eq "admin");
 768         return 1 if ($accesslevel eq "moderator");
 769         return 0 if $accesslevel eq "banned";
 770         return 0 if $permissions{$operation} eq "author" && $user ne $itemauthor;
 771         return 1;
 772 }
 773
 774 sub reply {
 775         my ($form,$cgi,$forum) = @_;
 776         if (! exists $forum->{authenticated} ) {
 777                 form_error($form,$cgi,$forum,"Вы не зарегистрировались") if (!authenticate($cgi,$forum));
 778         }
 779         #
 780         # Находим файл дискуссии, в который надо поместить реплику
 781         #
 782         my ($tree,$lockfd)=gettree($path_translated);
 783         my $newmsg = newlistelement($tree,"message","messagelist");
 784         if (!$newmsg) {
 785                 show_error($forum,"Шаблон темы не содержит элемента с классом
 786                 message");
 787                 exit;
 788         }
 789
 790         #
 791         # Генерируем идентификатор записи.
 792         #
 793         my $id = get_uid($forum);
 794
 795
 796         #
 797         # Сохраняем приаттаченные картинки, если есть.
 798         #
 799         my $dir = $path_translated;
 800
 801         $dir=~ s/[^\/]+$// if (-f $dir);
 802         my %attached;
 803         for (my $i=1;$cgi->param("image$i"); $i++) {
 804                 my $userpath=$cgi->param("image$i");
 805                 my $filename=lc($1) if $userpath =~ /([^\/\\]+)$/;
 806                 $attached{$filename} = $id."_".$filename;
 807                 my $in = $cgi->upload("image$i");
 808                 if (!$in) {
 809                         show_error($forum,"Ошибка при загрузке картинки $filename");
 810                         exit;
 811                 }
 812                 my $out;
 813                 open $out,">$dir/$attached{$filename}";
 814                 binmode $out,":bytes";
 815                 local $/=undef;
 816                 my $data = <$in>;
 817                 print $out $data;
 818                 close $in;
 819                 close $out;
 820         }
 821         #
 822         # Преобразуем текст записи в html и чистим его
 823         #
 824         my $txtree = input2tree($cgi,$forum,"text");
 825         #
 826         # Находим в тексте URL на приаттаченные картинки и меняем на те
 827         # имена, под которыми мы их сохранили.
 828         #
 829         for my $image ($txtree->find_by_tag_name("img")) {
 830                 my $file=lc($image->attr("src"));
 831                 if ( exists $attached{$file}) {
 832                         $image->attr("src" => $attached{$file});
 833                         my ($width,$height) = imgsize($dir ."/".$attached{$file});
 834                         $image->attr("width" =>$width);
 835                         $image->attr("height" => $height);
 836                 }
 837         }
 838         #
 839         # Подставляем данные сообщения
 840         #
 841         $newmsg->attr("id"=>$id);
 842         substinfo($newmsg,[class=>"subject"],_content=>$cgi->param("subject"));
 843         my $textnode=$newmsg->look_down("class"=>"mtext");
 844         if (!$textnode) {
 845                 show_error($forum,"В шаблоне реплики нет места для текста");
 846         }
 847         $textnode->delete_content();
 848         $textnode->push_content($txtree);
 849         if ($forum->{authenticated}{signature}) {
 850                 $textnode->push_content(new HTML::Element("br"),"--",
 851                 new HTML::Element("br"),str2tree($forum->{authenticated}{signature}));
 852         }
 853         substitute_user_info($newmsg,$forum);
 854         #
 855         # Подставляем данные в форму msginfo
 856         #
 857         my $editform=$newmsg->look_down(_tag=>"form","class"=>"msginfo");
 858         if ($editform) {
 859                 substinfo($editform,[_tag=>"input",name=>"id"],value=>$id) ||
 860                         show_error($forum,"В форме управления сообщением нет поля id");
 861                 substinfo($editform,[_tag=>"input",name=>"author"],value=>
 862                         $forum->{authenticated}{user}) ||
 863                         show_error($forum,"В форме управления сообщением нет поля author");
 864         }
 865         # Подставляем mdate
 866         substinfo($newmsg,["class"=>"mdate"],
 867                 _content =>strftime("%d.%m.%Y %H:%M",localtime()));
 868         # Подставляем mreply
 869         substinfo($newmsg,[_tag=>"a","class"=>"mreply"],"href" =>
 870          $cgi->url(-absolute=>1,-path_info=>1)."?reply=1&id=$id");
 871         # Подставляем manchor
 872         substinfo($newmsg,[_tag=>"a","class"=>"manchor"],
 873                 "name"=>"#$id","href"=>undef) or
 874                 show_error($forum,"В шаблоне сообщения отсутствует якорь для ссылок на него");
 875         # подставляем mlink
 876         substinfo($newmsg,[_tag=>"a","class"=>"mlink"],
 877                 href=>$cgi->path_info."#id");
 878         # подставляем mparent
 879         my $parent_id=$cgi->param("id");
 880         if ($parent_id) {
 881                 substinfo($newmsg,[_tag => "a",class=>"mparent"],
 882                         "href"=>$cgi->path_info."#$parent_id",style=>undef);
 883         } else {
 884                 substinfo($newmsg,[_tag => "a",class=>"mparent"],
 885                         style=>"display: none;");
 886         }
 887
 888         #
 889         # Делаем Уфф и сохраняем то, что получилось
 890         #
 891         savetree($path_translated,$tree,$lockfd);
 892         record_statistics($forum,"message"),
 893         forum_redirect($cgi,$forum);
 894
 895 }
 896 #
 897 # Обработка операции создания новой темы.
 898 #
 899
 900 sub new_topic {
 901         my ($form,$cgi,$forum) = @_;
 902         #
 903         # Проверяем корректность urlname и прочих полей
 904         #
 905         my $urlname;
 906         if (!$cgi->param("urlname")) {
 907                 $urlname = get_uid($forum);
 908         } else {
 909                 $urlname=$1 if $cgi->param("urlname") =~ /^([-\w]+)$/;
 910                 form_error($form,$cgi,$forum,"Некорректные символы в urlname.
 911                 Допустимы только латинские буквы, цифры и минус") unless $urlname;
 912         }
 913         if (!-d $path_translated) {
 914                 show_error($forum,"Операция $form может быть вызвана только со
 915                 страницы форума");
 916         }
 917         my $filename = "$path_translated/$urlname.html";
 918         if (-f $filename) {
 919                 form_error($form,$cgi,$forum,"Тема с urlname $urlname уже
 920                 существует");
 921         }
 922         my $url = $cgi->url(-absolute=>1,-path_info=>1)."/$urlname.html";
 923                 $url =~ s/\/+/\//g;
 924         if (!$cgi->param("title")) {
 925                 form_error($form,$cgi,$forum,"Тема должна иметь непустое название");
 926         }
 927         #
 928         # Создаем собственно тему
 929         #
 930         my $tree = gettemplate($forum,"topic",$url);
 931     # Заполнить название и аннотацию
 932         my $abstract = input2tree($cgi,$forum,"abstract");
 933         substinfo($tree,[_tag=>"meta","name"=>"description"],content=>$abstract->as_trimmed_text);
 934         substinfo($tree,[_tag=>"title"],_content=>$cgi->param("title"));
 935         my $subtree = $tree->look_down("class"=>"topic");
 936         my $creation_time=strftime("%d.%m.%Y %H:%M",localtime());
 937         if ($subtree) {
 938                 substinfo($subtree,["class"=>"title"],
 939                 _content=>$cgi->param("title"));
 940                 substinfo($subtree,["class"=>"date"],
 941                         _content=>$creation_time);
 942                 # Вставляем в страницу КОПИЮ аннотации, поскольку аннотация
 943                 # нам еще понадобится в списке тем.
 944                 substinfo($subtree,["class"=>"abstract"],_content=>$abstract->clone);
 945                 substitute_user_info($subtree,$forum);
 946         } else {
 947                 substinfo($tree,["class"=>"title"],
 948                 _content=>$cgi->param("title"));
 949         }
 950         # Скрыть список сообщений.
 951         hide_list($tree,"messagelist");
 952         savetree($filename,$tree,undef);
 953         $tree->destroy;
 954         #
 955         # Добавляем элемент в список тем текущего форума
 956         #
 957
 958         my $lockfd;
 959         ($tree,$lockfd)=gettree($path_translated."/".$forum->{"indexfile"});
 960         my $newtopic = newlistelement($tree,"topic","topiclist");
 961         substinfo($newtopic,[_tag=>"a","class"=>"title"],
 962         _content=>$cgi->param("title"), href=>"$urlname.html");
 963         substinfo($newtopic,["class"=>"date"], _content=>$creation_time);
 964         substinfo($newtopic,["class"=>"abstract"],_content=>$abstract);
 965         substitute_user_info($newtopic,$forum);
 966         $newtopic->attr("id",$urlname);
 967         my $controlform = $newtopic->look_down(_tag=>"form",class=>"topicinfo");
 968         if ($controlform) {
 969                 $controlform->attr("action"=>$url);
 970                 substinfo($controlform,[_tag=>"input",name=>"author"],value=>
 971                         $forum->{authenticated}{user});
 972         }
 973         savetree($path_translated."/".$forum->{"indexfile"},$tree,$lockfd);
 974         record_statistics($forum,"topic");
 975         forum_redirect($cgi,$forum,$cgi->url(-base=>1).$url);
 976 }
 977
 978 sub new_forum {
 979         my ($form,$cgi,$forum) = @_;
 980         #
 981         # Проверяем корректность urlname и прочих полей
 982         #
 983         my $urlname;
 984          if (!$cgi->param("urlname")) {
 985                 form_error($form,$cgi,$forum,"Форуму необходимо задать непустое urlname");
 986          }
 987          if ($cgi->param("urlname") eq ".") {
 988                 $urlname = "."
 989          } else {
 990                 $urlname=$1 if $cgi->param("urlname") =~ /^([-\w]+)$/ ;
 991                 form_error($form,$cgi,$forum,"Некорректные символы в urlname.
 992                         Допустимы только латинские буквы, цифры и минус") unless $urlname;
 993         }
 994         if (!-d $path_translated) {
 995                 show_error($forum,"Операция $form может быть вызвана только со
 996                 страницы форума");
 997         }
 998         my $newname = "$path_translated/$urlname";
 999         $newname=$path_translated if ($urlname eq ".");
1000         my $filename = "$newname/$forum->{indexfile}";
1001         if (-f $filename) {
1002                 form_error($form,$cgi,$forum,"Форум $urlname уже существует");
1003         }
1004         if (!$cgi->param("title")) {
1005                 form_error($form,$cgi,$forum,"Форум должен иметь непустое название");
1006         }
1007         mkdir $newname unless -d $newname;
1008         #
1009         # Сохраняем логотип
1010         #
1011         my ($logo_name,$logo_width,$logo_height);
1012         if ($cgi->param("logo")) {
1013                 my $userpath = $cgi->param("logo");
1014                 $logo_name="logo.".lc($1) if $userpath=~/\.([^.]+)$/;
1015                 my $in = $cgi->upload("logo");
1016                 if (!$in) {
1017                         show_error($forum,"Ошибка при загрузке картинки $userpath");
1018                         exit;
1019                 }
1020                 my $out;
1021                 open $out,">$newname/$logo_name";
1022                 binmode $out,":bytes";
1023                 local $/=undef;
1024                 my $data = <$in>;
1025                 print $out $data;
1026                 close $in;
1027                 close $out;
1028                 ($logo_width,$logo_height) = imgsize("$newname/$logo_name");
1029         } else {
1030                 $logo_name = $forum->{"templatesurl"}."/1x1.gif";
1031                 $logo_width = 1;
1032                 $logo_height=1;
1033         }
1034
1035
1036         #
1037         # Создаем собственно оглавление форума
1038         #
1039
1040         my $url = $cgi->path_info."/$urlname";
1041         $url =~ s/\/+/\//g;
1042         my $tree = gettemplate($forum,"forum",$url);
1043     # Заполнить название и аннотацию
1044         my $abstract = input2tree($cgi,$forum,"abstract");
1045         substinfo($tree,[_tag=>"meta","name"=>"description"],content=>$abstract->as_trimmed_text);
1046         substinfo($tree,[_tag=>"title"],_content=>$cgi->param("title"));
1047         my $subtree = $tree->look_down("class"=>"annotation")
1048                 or show_error($forum,"В шаблоне форума отсутствует класс annotation");
1049         my $creation_time=strftime("%d.%m.%Y %H:%M",localtime());
1050                 substinfo($subtree,["class"=>"title"],
1051                 _content=>$cgi->param("title"));
1052                 substinfo($subtree,["class"=>"date"],
1053                         _content=>$creation_time);
1054                 # Вставляем в страницу КОПИЮ аннотации, поскольку аннотация
1055                 # нам еще понадобится в списке тем.
1056                 substinfo($subtree,["class"=>"abstract"],_content=>$abstract->clone);
1057                 substitute_user_info($subtree,$forum);
1058         substinfo($subtree,[_tag=>"img","class"=>"logo"],
1059                 src=> $logo_name, width=>$logo_width, height=>$logo_height);
1060         # Скрыть списки подфорумов и тем .
1061         hide_list($tree,"forumlist");
1062         hide_list($tree,"topiclist");
1063         if ($urlname eq ".") {
1064                 for my $link_up ($tree->look_down(_tag=>"a",href=>"..")) {
1065                         $link_up->delete;
1066                 }
1067         }
1068         savetree($filename,$tree,undef);
1069         $tree->destroy;
1070         #
1071         # Добавляем элемент в список тем текущего форума
1072         #
1073         if ($urlname ne ".") {
1074         my $lockfd;
1075         ($tree,$lockfd)=gettree($path_translated."/".$forum->{"indexfile"});
1076         my $newforum = newlistelement($tree,"forum","forumlist");
1077         substinfo($newforum,[_tag=>"a","class"=>"title"],
1078         _content=>$cgi->param("title"), href=>"$urlname/");
1079         substinfo($newforum,["class"=>"date"], _content=>$creation_time);
1080         substinfo($newforum,["class"=>"abstract"],_content=>$abstract);
1081         substinfo($newforum,[_tag=>"img","class"=>"logo"],src=>"$urlname/$logo_name",
1082                 width=>$logo_width,height=>$logo_height);
1083         substitute_user_info($newforum,$forum);
1084         $newforum->attr("id",$urlname);
1085         my $controlform = $newforum->look_down(_tag=>"form",class=>"foruminfo");
1086         if ($controlform) {
1087                 $controlform->attr("action"=>$cgi->url(-absolute=>1,-path_info=>0).
1088                 $url);
1089                 substinfo($controlform,[_tag=>"input",name=>"author"],value=>
1090                         $forum->{authenticated}{user});
1091         }
1092         savetree($path_translated."/".$forum->{"indexfile"},$tree,$lockfd);
1093         record_statistics($forum,"forum");
1094         }
1095         forum_redirect($cgi,$forum,$cgi->url(-base=>1).$url);
1096 }
1097
1098 #----------------------------------------------------------
1099 # База пользователей и права доступа
1100 #----------------------------------------------------------
1101 #
1102 # Записывает в базу данных пользователей, сколько каких объектов
1103 # создал текущий пользователь
1104 #
1105 sub record_statistics {
1106         my ($forum,$type) = @_;
1107         my $user = $forum->{authenticated}{user};
1108         my %base;
1109         dbmopen %base,datafile($forum,"passwd"),0664;
1110         my $userinfo = thaw($base{$user});
1111         $userinfo->{$type."s"}++;
1112         $userinfo->{"last_$type"}=time;
1113         $base{$user} = freeze($userinfo);
1114         dbmclose %base;
1115 }
1116 #
1117 # читает файлы прав доступа в дереве форума, и возвращает
1118 # статус текущего пользователя (undef - аноним, banned, normal,
1119 # moderator или admin
1120
1121 sub getrights {
1122         my ($cgi,$forum) = @_;
1123         if (!$forum->{authenticated}) {
1124                 return undef;
1125         }
1126         my $user = $forum->{authenticated}{user};
1127         my $dir = $path_translated;
1128         $dir =~s/\/$//;
1129         $dir =~s/\/[^\/]+$// if (!-d $dir);
1130         my $f;
1131         my $user_status = "normal";
1132         LEVEL:
1133         while (length($dir)) {
1134                 print STDERR "Searcghing for perms in $dir\n";
1135                 if (-f "$dir/perms.txt") {
1136                         open $f,"<","$dir/perms.txt";
1137                         my $status = undef;
1138                         while (<$f>) {
1139                                 if (/^\[\s*(admins|moderators|banned)\s*\]/) {
1140                                         $status = $1;
1141                                 } else {
1142                                         chomp;
1143                                         if  ($user eq $_ && defined $status) {
1144                                                 if ($status eq "banned") {
1145                                                         return $status;
1146                                                 }
1147                                                 if ($status eq "admins" ) {
1148                                                         return "admin";
1149                                                 }
1150                                                 $user_status = "moderator";
1151                                         }
1152                                 }
1153                         }
1154                         close $f;
1155                         last LEVEL if  -f "$dir/.forum";
1156                 }
1157                 # Strip last path component.
1158                 $dir =~s/\/[^\/]+$//
1159         }
1160         return $user_status;
1161
1162 }
1163
1164
1165
1166 #------------------------------------------------------------------
1167 # Работа с файлами и идентификторами
1168 #------------------------------------------------------------------
1169
1170 #
1171 # Залочить файл и получить его распрасенное представление.
1172 # Возвращает пару ($tree,$lockfd)
1173
1174 sub gettree {
1175         my $filename = shift;
1176         my $f;
1177         open $f,"<",$filename or return undef;
1178         flock $f, LOCK_EX;
1179         my $tree = HTML::TreeBuilder->new_from_file($f);
1180         return ($tree,$f);
1181 }
1182 #
1183 # Сохранить дерево и закрыть lockfd.
1184 #
1185 #
1186
1187 sub savetree {
1188         my ($filename,$tree,$lockfd) = @_;
1189         my $f;
1190         open $f,">",$filename . ".new" or return undef;
1191         print $f $tree->as_HTML("<>&");
1192         close $f;
1193         # FIXME - только для POSIX.
1194         unlink $filename;
1195         rename $filename.".new",$filename;
1196         close $lockfd if defined($lockfd);
1197 }
1198 #
1199 # Читает шаблон и подготавливает его к размещению по указанной URL.
1200 # Если url не указана, считается что шаблон будет показан как результат
1201 # текущего http-запроса.
1202
1203 sub gettemplate {
1204         my ($forum, $template,$url) = @_;
1205         $url =~ s/\/+/\//g;
1206         my $filename=$forum->{"templates"}."/$template.html";
1207         if (! -r $filename) {
1208                 show_error($forum,"Нет шаблона $template");
1209                 exit;
1210         }
1211         my $tree = HTML::TreeBuilder->new_from_file($filename);
1212         fix_forum_links($forum,$tree,$url);
1213         return $tree;
1214 }
1215
1216
1217 #
1218 # Получает уникальный числовой идентификатор.
1219 #
1220 sub get_uid {
1221         my $forum = shift;
1222         my $f;
1223         open $f,"+<",datafile($forum,"sequence") or
1224         flock $f,LOCK_EX;
1225         my $id=<$f> || "0";
1226         $id++;
1227         seek $f,0,0;
1228         printf $f "%8s\n",$id;
1229         close $f;
1230         $id=~/(\d+)/;
1231         return sprintf ("%08s",$1);
1232 }
1233 # --------------------------------------------------------------------
1234 #  OpenID registration
1235 # -------------------------------------------------------------------
1236 sub create_openid_consumer {
1237         my ($cgi,$forum) = @_;
1238         return Net::OpenID::Consumer ->new(
1239                 ua => LWP::UserAgent->new( agent => "Stilllife/1.0"),
1240                 args => $cgi,
1241                 consumer_secret=>"X9RWPo0rBE7yLja6VB3d",
1242                 required_root => $cgi->url(-base=>1));
1243 }
1244
1245 # openidstart - вызывается когда обнаружено что текущее имя
1246 # пользователя, пытающегося аутентифицироваться, содержит http://
1247 #
1248 #
1249
1250 sub openidstart {
1251         my ($cgi,$forum,$openidurl) = @_;
1252         #
1253         # Fix duplicated http:// which can be produced by our sprintf based
1254         # login system
1255         #
1256         $openidurl=~s!^http://http://!http://!;
1257         my $csr = create_openid_consumer($cgi,$forum);
1258         my $claimed_identity=$csr->claimed_identity($openidurl);
1259         if (!defined $claimed_identity) {
1260                 show_error($forum,"Указанная URL $openidurl не является OpenId");
1261                 exit;
1262         }
1263         $cgi->param("openidvfy",1);
1264         $cgi->delete("user");
1265         $cgi->delete("openidsite");
1266         $cgi->delete("password");
1267         my $check_url = $claimed_identity->check_url(
1268                 return_to=> $cgi->url(-full=>1,-path_info=>1,-query=>1),
1269                 trust_root=> $cgi->url(-base=>1));
1270         print $cgi->redirect(-location=>$check_url);
1271         exit;
1272 }
1273 #
1274 # Вызывается при редиректе от openid producer-а. Проверяет, что
1275 # удаленный сервер подтвердил openid и вызывает операцию для которой
1276 # (либо возврат на исходную страницу при операции login, либо постинг
1277 # реплики)
1278 #
1279 sub openid_verify {
1280         my ($cgi,$forum) = @_;
1281         my $csr  = create_openid_consumer($cgi,$forum);
1282         if (my $setup_url = $csr->user_setup_url) {
1283                 print $cgi->redirect(-location=>$setup_url);
1284                 exit;
1285         } elsif ($csr->user_cancel) {
1286                 show_error($forum,"Ваш openid-сервер отказался подтвержать вашу
1287                 идентичность");
1288                 exit;
1289         } elsif (my $vident = $csr->verified_identity) {
1290                 #Успешная аутентификация.
1291                 #Создаем сессию
1292                 my $user = $vident->url;
1293                 # Remove trailing slash from URL if any
1294                 $user=~s/\/$//;
1295                 my %userbase;
1296                 dbmopen %userbase,datafile($forum,"passwd"),0664;
1297                 my $username = $user;
1298                 $username =~ s/^http:\/\///;
1299                 if (!$userbase{$username}) {
1300                         # Тащим foaf, если получится
1301                         my %info=get_foaf($csr->ua,$vident->declared_foaf);
1302                         if (ref($info{'avatar'}) eq "HASH" ) {
1303                                 delete $info{'avatar'}{'type'};
1304                         }
1305                         $info{"openiduser"}=1;
1306                         $forum->{authenticated}=\%info;
1307                         $userbase{$username} = freeze(\%info);
1308                 } else {
1309                         $forum->{authenticated} = thaw ($userbase{$username});
1310                 }
1311                 dbmclose %userbase;
1312                 $forum->{"authenticated"}{"user"} = $username;
1313                 newsession(undef,$forum,$user);
1314                 # Если указан параметр reply, вызываем обработку реплики
1315                 if ($cgi->param("reply")) {
1316                         reply("reply",$cgi,$forum);
1317                         exit;
1318                 }
1319                 #Иначе, возвращаемся на исходную страницу
1320                 forum_redirect($cgi,$forum,undef);
1321         }       else {
1322                 show_error($forum,"Ошибка OpenId аутентификации");
1323                 exit;
1324         }
1325 }
1326
1327 sub get_foaf {
1328         my ($ua,$foaf_url) = @_;
1329         my $response = $ua->get($foaf_url);
1330         unless ($response->is_success) {
1331                 print STDERR "Error geting foaf from $foaf_url\n";
1332                 return ();
1333         }
1334         my $foaf = $response->content;
1335         my %info = foaf_parse($foaf);
1336         if ($info{avatar}) {
1337                 $response = $ua->get($info{avatar});
1338                 if ($response->is_success) {
1339                         my $image = $response->content;
1340                         my ($w,$h,$type) = imgsize(\$image);
1341                         $info{avatar}={width=>$w,height=>$h,type=>$type,src=>$info{avatar}};
1342                 } else {
1343                         print STDERR "Error getting $info{avatar}: ".$response->status_line,"\n";
1344                 }
1345         }
1346         return %info;
1347 }
1348 sub foaf_parse {
1349         my $foaf = shift;
1350         my ($starttag) = $foaf =~ /<(\w+(:\w+)?[^>]+)>/sg;
1351         my %ns = reverse ($starttag =~ /xmlns:(\w+)="([^"]+)"/sg);
1352         my $foaf_prefix = $ns{"http://xmlns.com/foaf/0.1/"};
1353         my $rdf_prefix = $ns{"http://www.w3.org/1999/02/22-rdf-syntax-ns#"};
1354         my ($userpic) = $foaf=~/<$foaf_prefix:img[^>]* $rdf_prefix:resource="([^"]+)"/s;
1355         my @info;
1356         push @info, avatar =>$userpic if $userpic;
1357         my ($icq) = $foaf =~/<$foaf_prefix:icqChatID>([^<]*)<\/$foaf_prefix:icqChatID>/s;
1358         push @info, icq => $icq if ($icq);
1359         my ($jabber) = $foaf =~/<$foaf_prefix:jabberID>([^<]*)<\/$foaf_prefix:jabberID>/s;
1360         push @info, jabber => $jabber if ($jabber);
1361         return @info;
1362 }
1363 #-----------------------------------------------------------------
1364 # Обработка форматированных текстовых полей
1365 #-----------------------------------------------------------------
1366
1367 sub input2tree {
1368         my ($cgi,$forum,$field_name) = @_;
1369         my $format = $cgi->param($field_name."_format");
1370         my $text = $cgi->param($field_name);
1371         if ($format eq "bbcode") {
1372                 my $parser = HTML::BBReverse->new();
1373                 $text="<div class=\"bbcode\">".$parser->parse($text)."</div>";
1374         } elsif ($format eq "text") {
1375                 $text=~s/\r?\n\r?\n/<\/p><p class=\"text\">/;
1376                 $text=~s/\r?\n/<br>/;
1377                 $text = "<div><p class=\"text\">".$text."</p></div>";
1378         }
1379         my $txtree = str2tree($text);
1380         for my $badtag
1381         ("script","style","head","html","object","embed","iframe","frameset","frame",
1382         ($forum->{forbid_tags}?split(/\s*,\s*/,$forum->{forbid_tags}):())) {
1383                 for my $element ($txtree->find_by_tag_name($badtag)) {
1384                         $element->delete() if defined $element;
1385                 }
1386         }
1387         # Проверяем на наличие URL-ок не оформленных ссылками.
1388         return $txtree;
1389 }
1390
1391
1392
1393 sub str2tree {
1394         my ($data)=@_;
1395         my $tree = HTML::TreeBuilder->new();
1396         # Set parser options here
1397         $tree->parse("<html><body><div>$data</div></body></html>");
1398         $tree->eof;
1399         my $element=$tree->find("body");
1400         while (($element =($element->content_list)[0])->tag ne "div") {
1401         }
1402         $element->detach;
1403         $tree->destroy;
1404         return $element;
1405 }
1406
1407 sub tree2str {
1408         my ($tree)=@_;
1409         return $tree->as_HTML("<>&");
1410 }
1411
1412 #------------------------------------------------------------------------
1413 # Подстановка в дереве
1414 #------------------------------------------------------------------------
1415 # Находит
1416 # элемент указанного класса и удаляет display: none из его атрибута
1417 # style. Возвращает 1, если элемент был раскрыт, и 0, если он и до этого
1418 # был видимым.
1419 sub unhide_list {
1420         my ($tree,$class) = @_;
1421         my $msglist = $tree->look_down("class"=>$class);
1422         if ($msglist) {
1423                 my $style = $msglist->attr("style");
1424                 if ($style && $style =~ s/display: none;//) {
1425                         $msglist->attr("style",$style);
1426                         return 1;
1427                 } else {
1428                         return 0;
1429                 }
1430         }
1431 }
1432 #
1433 # Находит первый элемент указанного класса, и приписывает ему display:
1434 # none в style.
1435 #
1436 sub hide_list {
1437         my ($tree,$class)=@_;
1438         my $msglist = $tree->look_down("class"=>$class);
1439         return undef unless $msglist;
1440         if (!$msglist->attr("style")) {
1441                 $msglist->attr("style","display: none;");
1442         } else {
1443                 my $style = $msglist->attr("style");
1444                 unless ($style=~ s/\bdisplay:\s+\w+\s*;/display: none;/) {
1445                         $style .= "display: none;";
1446                 }
1447                 $msglist->attr("style",$style);
1448         }
1449         return 1;
1450 }
1451 #
1452 # Найти все элементы, удоволетворяющие заданному критерию и подставить в
1453 # них указанные атрибуты
1454 #
1455 # Параметры 1. Дерево (класса HTML::Element)
1456 # 2. Запрос - ссылка на список вида атрибут=>значение.
1457 #    Этот список будет непосредственно передан в
1458 #    HTML::Element::look_down
1459 # 3. Далее пары имя-атрибута, значение. Если вместо имени атрибута
1460 #    использовать слово _content, заменено будет содержимое элемента.
1461 #    Значение для _content - ссылка на HTML::Element. Если там строка,
1462 #    она будет вставлена как одиночный текстовый узел.
1463 # 4. Возвращает число выполненных подстановок (0, если искомых элементов
1464 #   не найдено.
1465 #
1466 sub substinfo {
1467         my ($tree,$query,@attrs) = @_;
1468         my $count;
1469         foreach my $element ($tree->look_down(@$query)) {
1470                 $count ++;
1471                 while (@attrs) {
1472                         my $attr = shift @attrs;
1473                         my $value = shift @attrs;
1474                         if ($attr eq "_content") {
1475                                 $element->delete_content;
1476                                 $element->push_content($value);
1477                         } else {
1478                                 $element->attr($attr,$value);
1479                         }
1480                 }
1481         }
1482         return $count;
1483 }
1484 #
1485 # newlistelement($tree,$elementclass,$listclass)
1486 #
1487 # Если список с указанным классом скрыт, раскрывает его и возвращает
1488 # (единственный) элемент
1489 sub newlistelement {
1490         my ($tree,$element,$list) =@_;
1491         my $msglist = $tree->look_down("class"=>$list);
1492         if ($msglist) {
1493                 my $style = $msglist->attr("style");
1494                 if ($style && $style =~ s/display: none;//) {
1495                         $msglist->attr("style",$style);
1496                         return $msglist->look_down(class=>$element);
1497                 } else {
1498                         my $template = $msglist->look_down("class"=>$element);
1499                         return undef unless $template;
1500                         my $newitem=$template->clone;
1501                         $template->parent->push_content($newitem);
1502                         return $newitem;
1503                 }
1504         } else {
1505                 return undef;
1506         }
1507 }