forum/forum

   1 #!/usr/bin/perl -T
   2
   3 use strict;
   4 use warnings;
   5 use CGI;
   6 use HTML::TreeBuilder;
   7 use Storable qw(freeze thaw);
   8 use Date::Parse;
   9 use Email::Valid;
  10 #
  11 # Набор поддерживаемых действий. Хэш вида
  12 # "имя поля в запросе" =>  "функция обработчик"
  13 #
  14 my %actions = (
  15         reply => \&reply,
  16         edit => \&edit_comment,
  17         delete => \&delete_comment,
  18         move => \&move_comment,
  19         newtopic=> \&new_topic,
  20         newforum=> \&new_forum,
  21         login => \&login,
  22         register=>\&register,
  23         profile=>\&profile,
  24         setrights=>\&set_rights,
  25         openidlogin=>\&openid_login,
  26         openidvfy =>\&openid_verify
  27 );
  28
  29
  30
  31 my $cgi = new CGI;
  32
  33 my $forum=get_forum_config();
  34
  35
  36 authorize_user($cgi,$forum);
  37 if ($cgi->request_method ne "POST") {
  38 # Запрос к скрипту методом GET. Надо показать форму, если только это не
  39 # редирект от OpenId-сервера
  40         if ($cgi->param('openidvfy')) {
  41                 openid_verify($cgi);
  42         } else {
  43                 for my $param ($cgi->param) {
  44 # Среди параметров, указанных в URL ищем тот, который задает
  45 # действие
  46                         if (exists $actions{$param}) {
  47 # Мы, конечно уже проверили, что в названии параметра
  48 # нехороших символов нет, но чтобы perl в taint mode не
  49 # ругался...
  50                                 if (allow_operation($param,$cgi,$forum)) {
  51                                         show_template($1,$cgi,$forum) if $param=~/^(\w+)$/;
  52                                         exit;
  53                                 } else {
  54                                         if (!$forum->{"authenticated"}) {
  55                                                 $cgi->param("returnto",$cgi->uri(-full=>1));
  56                                                 show_template("login",$cgi,$forum);
  57                                                 exit;
  58
  59                                         } else {
  60                                                 show_error($forum,"У Вас нет прав на  выполнение этой
  61                                                 операции")
  62                                         }
  63                                 }
  64                         }
  65                 }
  66                 show_error($forum,"Некорректный вызов скрипта. Отсутствует параметр
  67                                 действия");
  68         }
  69 } else {
  70         # Запрос методом POST. Вызываем обработчик
  71         for my $param ($cgi->param) {
  72                 if (exists $actions{$param}) {
  73                         $actions{$param}->($param,$cgi,$forum);
  74                         exit;
  75                 }
  76         }
  77         show_error($forum,"Некорректный вызов скрипта. Отсутствует параметр действия");
  78 }
  79 #
  80 # Поиск файла .forum вверх по дереву от $ENV{PATH_TRANSLATED}
  81 # Значение PATH_TRANSLATED считаем безопасным - наш web-сервер нам не
  82 # враг.
  83 # Возвращает список имя,значение, имя, значение который прививается в
  84 # хэш
  85
  86 sub get_forum_config {
  87         my @path=split("/",$1) if $ENV{PATH_TRANSLATED}=~/^(\S+)$/;
  88         while (@path>1) {
  89                 pop @path;
  90                 if (-r (my $config=join("/",@path,".forum")) ) {
  91                         open F,"<",$config;
  92                         my %config;
  93                         while (<F>) {
  94                                 s/#.*$//; #Drop comments;
  95                                 $config{$1}=$2 if /(\w+)\s*=\s*(\S.*)$/;
  96                         }
  97                         close F;
  98                         #
  99                         # Если в конфиге отсутствует переменная templates, но
 100                         # рядом с конфигом присутствует директория templates,
 101                         # то шаблоны там.
 102                         #
 103                         if (! exists $config{"templates"}
 104                                 && -d (my $filename = join("/",@path,"templates"))) {
 105                                         $config{"templates"} = $filename;
 106                         }
 107                         #
 108                         # То же самое - параметр userdir и директория users
 109                         #
 110                         if (! exists $config{"userdir"}
 111                                 && -d (my $filename = join("/",@path,"users"))) {
 112                                         $config{"userdir"} = $filename;
 113                                         my
 114                                         $taillen=length($ENV{PATH_TRANSLATED})-length(join("/",@path));
 115                                         $config{"userurl"} =
 116                                         $cgi->url(-base=>1).substr($ENV{'PATH_INFO'},0,
 117                                         length($ENV{'PATH_INFO'})-$taillen)."/users";
 118
 119
 120                         }
 121                         #
 122                         # Если нет ссылки в конфиге на файл паролей или он не
 123                         # существует, выдаем ошибку. С офоромлением, так как шаблоны
 124                         #  у нас уже есть
 125                         if (! exists $config{"passwd"}) {
 126                                 show_error(\%config,"В конфигурации форума не указан файл пользователей");
 127                                 exit;
 128                         }
 129                         if (!exists $config{"session"}) {
 130                                 show_error(\%config,"В конфигурации форума не указан файл сессий");
 131                                 exit;
 132                         }
 133                         $config{"authperiod"}="+1m" if (! exists $config{"authperiod"});
 134                         $config{"renewtime"} = "86000" if (!exists $config{"renewtime"});
 135                         return \%config;
 136                 }
 137         }
 138         #
 139         # Выводим ошибку 404 без осмысленного оформления, так как данных форума
 140         # мы не нашли
 141         print "Status: 404\nContent-Type: text/html; charset=utf-8\n\n",
 142         "<HTML><HEAD><TITLE>Форум не обнаружен</TITLE></HEAD><BODY>",
 143         "<H!>Форум не найден</H!>",
 144         "<p>Хвост URL, указанный при вызове скрипта  показывает не на
 145         форум</p>",
 146         # To make IE think this page is user friendly
 147         "<!--",("X" x 512),"--></body></html>\n";
 148         exit;
 149 }
 150 #
 151 # Вывод сообщения об ошибке по шаблону форума
 152 # Шаблон должен содержать элемент с классом error.
 153 #
 154 sub show_error {
 155         my ($cfg,$msg) = @_;
 156         if ( -r $cfg->{"templates"}."/error.html") {
 157                 my $tree = HTML::TreeBuilder->new_from_file($cfg->{"templates"}."/error.html");
 158                 my $node= $tree->find_by_attribute('class','error');
 159                 my $body;
 160                 if (!$node) {
 161                         $body = $tree->find_by_tagname('body');
 162                         $body->push_content($node = new
 163                         HTML::Element('div','class'=>'error'));
 164                 }
 165                 $node->delete_content;
 166                 $node->push_content($msg);
 167                 print $cgi->header(-type=>'text/html',-charset=>'utf-8');
 168                 print $tree->as_HTML("<>&");
 169         } else {
 170                 print $cgi->header(-type=>'text/html',-charset=>'utf-8');
 171                 print "<html><head><title>Ошибка конфигурации форума</title></head>",
 172                 "<body><h1>Ошибка конфигурации форума</h1><p>",
 173                 $cgi->escapeHTML($msg),"</p>",
 174                 "<p>При обработке этой ошибки не обнаружен шаблон сообщения об ошибке</p></body></html>";
 175         }
 176 }
 177 #
 178 # Вывод шаблона формы. В шаблоне должна присутстовать форма с
 179 # именем, совпадающим с именем form. Если в $cgi есть параметры, имена
 180 # которых совпадают с именами полей этой формы, их значения
 181 # подставляются
 182 #
 183 sub show_template {
 184         my ($form,$cgi,$forum) = @_;
 185         my $filename=$forum->{"templates"}."/$form.html";
 186         if (! -r $filename) {
 187                 show_error($forum,"Нет шаблона для операции $form");
 188                 exit;
 189         }
 190         my $tree = HTML::TreeBuilder->new_from_file($filename);
 191         # Находим форму с классом $form
 192         my $f = $tree->look_down("_tag","form",
 193                 "name",$form);
 194         if (! defined $f) {
 195                 # Если не нашли - ругаемся
 196                 show_error($forum,"Шаблон для операции $form не содержит формы с
 197                 именем $form");
 198                 exit;
 199         }
 200         if (!$cgi->param("returnto")) {
 201                 $cgi->param("returnto", $cgi->referer||$cgi->url(-absolute=>1,-path_info=>1));
 202
 203         }
 204         if (!$cgi->param($form)) {
 205                 $cgi->param($form,1);
 206         }
 207         #
 208         # Если ранее была выставлена ошибка с помощью set_error, подставляем
 209         # сообщение в элемент с классом error
 210         #
 211         if ($forum->{error_message}) {
 212                 my $errormsg = $tree->look_down("class"=>"error");
 213                 if ($errormsg) {
 214                         $errormsg->delete_content();
 215                         $errormsg->push_content($forum->{error_message});
 216                 }
 217         }
 218         if ($forum->{"authenticated"}) {
 219                 # Подставляем информацию о текущем пользователе если в шаблоне
 220                 # это предусмотрено
 221                 substitute_user_info($tree,$forum);
 222         }
 223         my %substituted;
 224         for my $element($f->find_by_tag_name("textarea","input","select")) {
 225                 my $name = $f->attr("name");
 226                 $substituted{$name} = 1;
 227                 if (defined  $cgi->param($name)) {
 228                         if ($f->tag eq "input") {
 229                                 if ($f->attr("type") eq "check") {
 230                                         if (grep($f->attr("value") eq $_,$cgi->param($name))) {
 231                                                 $f->attr("checked","");
 232                                         } else {
 233                                                 $f->attr("checked",undef);
 234                                         }
 235
 236                                 } elsif ($f->attr("type") eq
 237                                 "radio") {
 238                                         if ($f->attr("value") eq $cgi->param($name)) {
 239                                                 $f->attr("checked","");
 240                                         } else {
 241                                                 $f->attr("checked",undef);
 242                                         }
 243                                 } else {
 244                                 $f->attr("value",$cgi->param($name));
 245                                 }
 246                         } elsif ($f->tag eq "textarea") {
 247                                 $f->delete_content;
 248                                 $f->push_content($cgi->param("name"));
 249                         } elsif ($f->tag eq "select") {
 250                                 for my $option ($f->find_by_tag_name("option")) {
 251                                         if (grep($option->attr("value") eq $_, $cgi-param("name"))) {
 252                                                 $option->attr("selected","");
 253                                         } else {
 254                                                 $option->attr("selected",undef);
 255                                         }
 256                                 }
 257
 258                         }
 259                 }
 260
 261         }
 262         $f->attr("type","POST");
 263         $f->attr("action",$cgi->url(-full=>1,-path_info=>1,-query=>0));
 264         for my $required ($form,"returnto") {
 265                 if (!$substituted{$required}) {
 266                         my $element = new HTML::Element('input',
 267                                 'type' => 'hidden', 'name' => $required,
 268                                 'value'=> $cgi->param($required));
 269                         $f->push_content($element);
 270                 }
 271         }
 272
 273
 274         print
 275         $cgi->header(type=>"text/html",charset=>"utf-8",($forum->{cookies}?(-cookie=>$forum->{cookies}):())),
 276         $tree->as_HTML("<>&");
 277 }
 278
 279 #
 280 # Подставляет в заданное поддерево информацию о пользователе
 281 #
 282
 283 sub substitute_user_info {
 284
 285 my ($tree,$forum) = @_;
 286 my %userinfo = %{$forum->{"authenticated"}};
 287
 288 #
 289 # Специально обрабатываем поля user (должна быть ссылка) и avatar
 290 # (должен быть img).
 291
 292 my $userlink = $tree->look_down("_tag"=>"a","class"=>"author");
 293 if ($userlink) {
 294         $userlink->attr(href=>$userinfo{"userpage"});
 295         $userlink->delete_content();
 296         $userlink->push_content($userinfo{"user"});
 297 }
 298 delete $userinfo{"userpage"};
 299 delete $userinfo{"user"};
 300 my $avatar = $tree->look_down("_tag"=>"img","class"=>"avatar");
 301 if ($avatar) {
 302         $avatar->attr(src=>$userinfo{"avatar"});
 303 }
 304 delete $userinfo{"avatar"};
 305
 306 while (my ($field,$value)=each %userinfo) {
 307         my $element = $tree->look_down("class","a".$field);
 308         if ($element) {
 309                 $element->delete_content();
 310                 #
 311                 # FixME - allow HTML in author attributes
 312                 $element->push_content($value);
 313         }
 314
 315 }
 316
 317 }
 318 #
 319 # Авторизует зарегистрированного пользователя.
 320 # 1. Проверяет куку если есть
 321 #
 322
 323 sub authorize_user      {
 324         ($cgi,$forum) = @_;
 325         if (my $session=$cgi->cookie("slsession")) {
 326         # Пользователь имеет куку
 327                 my %sessbase;
 328                 dbmopen %sessbase,$forum->{"session"},0644;
 329                         if (exists($sessbase{$session}))  {
 330                                 my ($user,$expires,$ip)=split(";", $sessbase{$session});
 331                                 if (!defined $ip|| $ip eq $ENV{'REMOTE_ADDR'}) {
 332                                         my %userbase;
 333                                         dbmopen %userbase,$forum->{"passwd"},0644;
 334                                         if ( exists($userbase{$user})) {
 335                                                 my $userinfo = thaw($userbase{$user});
 336                                                 delete $userinfo->{"passwd"};
 337                                                 $userinfo->{"user"} = $user;
 338                                                 if ($expires-time()< $forum->{"renewtime" }) {
 339                                                         delete $sessbase{$session};
 340                                                         newsession(\%sessbase,$forum,$user,$ip);
 341                                                 }
 342                                                 $forum->{"authenticated"}=$userinfo;
 343                                         }
 344                                         dbmclose %userbase;
 345                                 }
 346                         }
 347                 dbmclose %sessbase;
 348         }
 349 }
 350
 351 #
 352 # Создает новую сессию для пользователя и подготавливает куку которую
 353 # сохраняет в хэше конфигурации форума
 354 #
 355 sub newsession {
 356         my ($base,$forum,$user,$bindip) = @_;
 357         if (!defined $base) {
 358                 $base = {};
 359                 dbmopen %$base,$forum->{"session"},0644;
 360         }
 361         my $sessname;
 362         my $t = time();
 363         my ($u,$expires,$ip);
 364         do {
 365                 $sessname = sprintf("%08x",rand(0xffffffff));
 366                 if ($base->{"sessname"}) {
 367                         ($u,$expires,$ip) = split ";", $base->{$sessname};
 368                         delete $base->{$sessname} if $expires < $t;
 369                 }
 370         } while ($base->{$sessname});
 371         my $cookie = $cgi->cookie(-name=>"slsession",
 372                 -expires => $forum->{"authperiod"},-value=> $sessname);
 373         $base->{$sessname}=$user.";".str2time($cookie->expires()).
 374                 ($ip?";$ENV{'REMOTE_ADDR'}":"");
 375
 376         $forum->{'cookie'}=[ $cookie,
 377         $cgi->cookie(-name=>"sluser",-value=>$user,-expires =>
 378         $forum->{authperiod})];
 379 }
 380 #
 381 # Выполняет аутентикацию пользователя по логину и паролю и
 382 # создает для него сессию.
 383 #
 384 sub authenticate {
 385         my ($cgi,$forum) = @_;
 386         if ($cgi->param("openidsite")) {
 387                 my $openid_url = sprintf($cgi->param("openidsite",$cgi->param("user")));
 388                 openidstart($cgi,$openid_url);
 389         }
 390         my %userbase;
 391         dbmopen %userbase,$forum->{"passwd"},0644;
 392         my $user = $cgi->param("user");
 393         if (! $userbase{$user}) {
 394           set_error($forum,"Неверное имя пользователя или пароль");
 395           return undef;
 396         }
 397         my $userinfo = thaw($userbase{$user}) ;
 398         dbmclose %userbase;
 399         if (crypt($user,$userinfo->{passwd}) eq $userinfo->{passwd}) {
 400                 delete $userinfo->{"passwd"};
 401                 $userinfo->{"user"} = $user;
 402                 newsession(undef,$forum,$user);
 403                 $forum->{"authenticated"} = $userinfo;
 404         } else {
 405                 set_error($forum,"Неверное имя пользователя или пароль");
 406         }
 407 }
 408 #
 409 # Запоминает сообщение об ошибке для последующего вывода show_template
 410 #
 411 sub set_error {
 412         my  ($forum,$message) = @_;
 413         $forum->{error_message} = $message;
 414 }
 415 #
 416 # Выводит текущий шаблно с сообщением об ошибке
 417 #
 418 sub form_error {
 419         my ($form_name,$cgi,$forum,$msg) = @_;
 420         set_error($forum,$msg);
 421         show_template($form_name,$cgi,$forum);
 422         exit;
 423 }
 424 #
 425 # Обработка результатов заполнения формы регистрации.
 426 #
 427 #
 428 sub register {
 429         my ($formname,$cgi,$forum) = @_;
 430         #
 431         # Возможные ошибки:
 432         # 1 Такой юзер уже есть
 433         #
 434         #  не заполнено поле user
 435         if (!$cgi->param("user")) {
 436                 form_error($formname,$cgi,$forum, "Не заполнено имя пользователя");
 437         }
 438         #  или поле password
 439         if (!$cgi->param("pass1"))  {
 440                 form_error($formname,$cgi,$forum,"Не указан пароль");
 441         }
 442         #  Копии пароля не совпали
 443         if ($cgi->param("pass2") ne $cgi->param("pass1")) {
 444                 form_error($formname,$cgi,$forum,"Ошибка при вводе пароля");
 445         }
 446         my $user = $cgi->param("user");
 447         # Не указаны поля, перечисленные в скрытом поле required
 448         if ($cgi->param("required")) {
 449                 foreach my $field (split(/\s*,\s*/,$cgi->param('required'))) {
 450                         if (!$cgi->param($field)) {
 451                                 form_error($formname,$cgi,$forum,"Не заполнено обязательное поле $field");
 452                         }
 453                 }
 454         }
 455         my %userbase;
 456         dbmopen %userbase,$forum->{"passwd"},0644
 457                 or form_error($formname,$cgi,$forum,"Ошибка открытия файла паролей $!");
 458         if ($userbase{$cgi->param("user")}) {
 459                 dbmclose %userbase;
 460                 form_error($formname,$cgi,$forum,"Имя пользователя '".$cgi->param("user"). "' уже занято");
 461         }
 462         if ($cgi->param("email") && !  Email::Valid->address($cgi->param("email"))) {
 463                 form_error($formname,$cgi,$forum,"Некорректный E-Mail адрес");
 464         }
 465         my $saltstring = 'ABCDEFGHIJKLMNOPQRSTUVWXUZabcdefghijklmnopqrstuvwxuz0123456789./';
 466         my $salt = substr($saltstring,int(rand(64)),1).
 467                                 substr($saltstring,int(rand(64)),1);
 468         my $password=crypt($cgi->param("pass1"),$salt);
 469         my $userinfo = {passwd=>$password};
 470         # Удаляем лишние поля
 471         $cgi->delete("required");
 472         $cgi->delete("register");
 473         $cgi->delete("user");
 474         $cgi->delete("pass1");
 475         $cgi->delete("pass2");
 476         foreach my $field (split(/\s*,\s*/,$cgi->param('ignore'))) {
 477                 if (!$cgi->param($field)) {
 478                         $cgi->delete($field);
 479                 }
 480         }
 481         my $returnto = $cgi->param("returnto");
 482         $cgi->delete("returnto");
 483         # Если есть аватар в файле, то сохраняем этот файл и формируем URL
 484         # на него.
 485         if ($cgi->param("avatarfile" )) {
 486                 my $f = $cgi->upload("avatarfile");
 487                 binmode $f,":bytes";
 488                 my $out;
 489                 my $filename = $1 if $cgi->param("avatarfile")=~/([^\/\\]+)$/;
 490                 open $out,">",$forum->{"userdir"}."/".$filename;
 491                 binmode $out,":bytes";
 492                 my $buffer;
 493                 while (my $bytes = read($f,$buffer,4096)) {
 494                         print $out $buffer;
 495                 }
 496                 close $f;
 497                 close $out;
 498                 $userinfo->{'avatar'}= $forum->{"userurl"}."/".$filename;
 499                 $cgi->delete("avatar");
 500                 $cgi->delete("avatarfile");
 501         }
 502
 503         foreach my $param       ($cgi->param) {
 504                 $userinfo->{$param} = $cgi->param($param);
 505         }
 506         $userinfo->{registered} = time;
 507         if (exists $forum->{default_status}) {
 508                 $userinfo->{status} = $forum->{default_status};
 509         }
 510         print STDERR "stilllife forum: registering user $user\n";
 511         $userbase{$user} = freeze($userinfo);
 512         dbmclose %userbase;
 513         newsession(undef,$forum,$user);
 514         if (defined $returnto) {
 515                 forum_redirect($returnto)
 516         } else {
 517                 forum_redirect($cgi->url(-base=>1).$ENV{PATH_INFO});
 518         }
 519
 520 }
 521
 522 sub allow_operation {
 523         my ($operation,$cgi,$forum) = @_;
 524         return 1 if (grep $operation eq $_,"register","login","reply");
 525
 526         return 1;
 527 }