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