selfforum-cgi/user/fo_posting.pl

   1 #!/usr/bin/perl -wT
   2
   3 ################################################################################
   4 #                                                                              #
   5 # File:        user/fo_posting.pl                                              #
   6 #                                                                              #
   7 # Authors:     André Malo <nd@o3media.de>, 2001-03-31                          #
   8 #                                                                              #
   9 # Description: Accept new postings, display "Neue Nachricht" page              #
  10 #                                                                              #
  11 # not ready, be patient please                                                 #
  12 #                                                                              #
  13 ################################################################################
  14
  15 use strict;
  16 use vars qw($Bin $Shared $Script);
  17
  18 # locate the script
  19 BEGIN {
  20   my $null = $0; $null =~ s/\\/\//g; # for win :-(
  21   ($Bin)    = ($null =~ /^(.*)\/.*$/)? $1 : '.';
  22   $Shared   = "$Bin/../shared";
  23   ($Script) = ($null =~ /^.*\/(.*)$/)? $1 : $null;
  24 }
  25
  26 use lib "$Shared";
  27 use CGI::Carp qw(fatalsToBrowser);
  28
  29 #use Conf;
  30 #use Encode::Plain; $Encode::Plain::utf8 = 1; # generally convert from UTF-8
  31 #use Id;
  32 #use Posting::Write;
  33 #use Template;
  34 #use Template::Posting;
  35
  36 #use autouse 'Encode::Posting' => qw();
  37
  38 # load script configuration and admin default conf.
  39 my $conf         = read_script_conf ($Bin, $Shared, $Script);
  40 my $adminDefault = read_admin_conf ($conf -> {files} -> {adminDefault});
  41
  42 # Initialize the request
  43 #
  44 my $request = new Posting::Request ($conf, $adminDefault);
  45
  46 # fetch and parse the cgi-params
  47 #
  48 $request -> parse_cgi;
  49
  50 # handle errors or save the posting
  51 #
  52 $request -> handle_error or $request -> save;
  53
  54 # show response
  55 #
  56 $request -> response;
  57
  58 #
  59 #
  60 ### main end ###################################################################
  61
  62 ################################################################################
  63 ### Posting::Request ###########################################################
  64 package Posting::Request;
  65
  66 use Lock          qw(:ALL);
  67 use Posting::_lib qw(
  68       hr_time
  69       parse_xml_file
  70       get_all_threads get_message_node get_message_header
  71       KEEP_DELETED
  72     );
  73
  74 use autouse 'CheckRFC' => qw[ is_email($) is_URL($@) ];
  75 use CGI;
  76
  77 ### sub new ####################################################################
  78 #
  79 # initialising the Posting::Request object
  80 # check parameters and fill in object properties
  81 #
  82 sub new {
  83   my ($class, $conf, $adminDefault) = @_;
  84
  85   my $sp = $conf -> {show} -> {Posting};
  86
  87   my $self = {
  88        conf => {
  89          original => $conf,
  90          admin    => $adminDefault,
  91
  92          message_path    => $conf -> {files} -> {messagePath},
  93          forum_file_name => $conf -> {files} -> {forum},
  94
  95          show_posting    => $sp,
  96          assign          => $sp -> {assign},
  97          form_must       => $sp -> {form} -> {must},
  98          form_data       => $sp -> {form} -> {data},
  99          form_action     => $sp -> {form} -> {action},
 100        },
 101
 102        template => new Template $sp -> {templateFile},
 103        response => {},
 104        forum    => {},
 105        error    => {}
 106      };
 107
 108   bless $self, $class;
 109 }
 110
 111 ### sub save ###################################################################
 112 #
 113 # save posting
 114 # check on legal reply or dupe is released here
 115 #
 116 # Return: -none-
 117 #
 118 sub save {
 119   my $self = shift;
 120
 121   # if an empty 'new message' document, there's nothing to save
 122   #
 123   return if ($self -> {response} -> {new_thread});
 124
 125   # lock and load the forum main file
 126   #
 127   if ($self -> load_main_file) {
 128
 129     # if a reply - is it legal?
 130     # is it a dupe?
 131     #
 132     if ($self -> check_reply_dupe) {
 133
 134       # we've got an opening
 135       #
 136       if ($self -> {response} -> {new}) {
 137         $self -> save_new;
 138       }
 139
 140       # we've got a reply
 141       #
 142       elsif ($self -> {response} -> {reply}) {
 143         $self -> save_reply;
 144       }
 145
 146       # don't know, if we any time come to this branch
 147       # the script is probably broken
 148       #
 149       else {
 150         $self -> {error} = {
 151           spec => 'unknown_error',
 152           type => 'fatal'
 153         };
 154       }
 155     }
 156   }
 157
 158   # unlock forum main file
 159   #
 160   if ($self -> {forum} -> {flocked}) {
 161     violent_unlock_file($self -> {forum_file_name}) unless unlock_file ($self -> {forum_file_name});
 162     $self -> {forum} -> {flocked} = 0;
 163   }
 164
 165   $self -> handle_error unless $self -> {check_success};
 166
 167   return;
 168 }
 169
 170 ### sub parse_cgi ##############################################################
 171 #
 172 # fetch and decode cgi-parameters,
 173 # find out the kind of response requested by the user (new message, reply)
 174 #
 175 # Return: -none-
 176 #
 177 sub parse_cgi {
 178   my $self = shift;
 179
 180   # create the CGI object
 181   #
 182   my $q = new CGI;
 183   $self -> {cgi_object} = $q;
 184
 185   # check the params
 186   #
 187   $self -> {check_success} = $self -> check_cgi;
 188
 189   return;
 190 }
 191
 192 ### sub load_main_file #########################################################
 193 #
 194 # load and parse the forum main file
 195 #
 196 # Return: Success (true/false)
 197 #
 198 sub load_main_file {
 199   my $self = shift;
 200   my $lock_stat;
 201
 202   unless ($lock_stat = write_lock_file ($self ->{forum_file_name})) {
 203     if ($lock_stat == 0) {
 204       # occupied or no w-bit set for the directory..., hmmm
 205       #
 206       violent_unlock_file ($self -> {forum_file_name});
 207       $self -> {error} = {
 208         spec => 'occupied',
 209         type => 'fatal'
 210       };
 211       return;
 212     }
 213     else {
 214       # master lock is set
 215       #
 216       $self -> {error} = {
 217         spec => 'master_lock',
 218         type => 'fatal'
 219       };
 220       return;
 221     }
 222   }
 223   else {
 224     $self -> {forum} -> {flocked} = 1;
 225     ( $self -> {forum} -> {threads},
 226       $self -> {forum} -> {last_thread},
 227       $self -> {forum} -> {last_message},
 228       undef,
 229       $self -> {forum} -> {unids}
 230     ) = get_all_threads ($self -> {forum_file_name}, KEEP_DELETED);
 231   }
 232
 233   # ok, looks good
 234   1;
 235 }
 236
 237 ### sub check_reply_dupe #######################################################
 238 #
 239 # check whether a reply is legal
 240 # (followup posting must exists)
 241 #
 242 # check whether this form request is a dupe
 243 # (unique id already exists)
 244 #
 245 # Return: Status Code (Bool)
 246 #
 247 sub check_reply_dupe {
 248   my $self = shift;
 249
 250   # return true unless it's not a reply
 251   #
 252   return 1 unless (
 253     $self -> {response} -> {reply}
 254     and $self -> {response} -> {new}
 255   );
 256
 257   my %unids;
 258
 259   if ($self -> {response} -> {reply}) {
 260
 261     my ($threads, $ftid, $fmid, $i, %msg, %unids) = (
 262           $self -> {forum} -> {threads},
 263           $self -> {fup_tid},
 264           $self -> {fup_mid}
 265        );
 266
 267     # thread doesn't exist
 268     #
 269     unless (exists($threads -> {$ftid})) {
 270       $self -> {error} = {
 271         spec => 'no_reply',
 272         type => 'fatal'
 273       };
 274       return;
 275     }
 276
 277     # build a reverse lookup hash (mid => number in array)
 278     # and ignore invisible messages
 279     # (users can't reply to "deleted" msg)
 280     #
 281     for ($i=0; $i < @{$threads -> {$ftid}}; $i++) {
 282
 283       if ($threads -> {$ftid} -> [$i] -> {deleted}) {
 284         $i+=$threads -> {$ftid} -> [$i] -> {answers};
 285       }
 286       else {
 287         $msg{$threads -> {$ftid} -> [$i] -> {mid}}=$i;
 288       }
 289     }
 290
 291     # message doesn't exist
 292     #
 293     unless (exists($msg{$fmid})) {
 294       $self -> {error} = {
 295         spec => 'no_reply',
 296         type => 'fatal'
 297       };
 298       return;
 299     }
 300
 301     # build a unique id lookup hash
 302     # use the unids of parent message's kids
 303     #
 304     %unids = map {$_ => 1} @{$threads -> {$ftid} -> [$msg{$fmid}] -> {unids}};
 305   }
 306   else {
 307     # build a unique id lookup hash, too
 308     # but use only the level-zero-messages
 309     #
 310     %unids = map {$_ => 1} @{$self -> {unids}};
 311   }
 312
 313   # now check on dupe
 314   #
 315   if (exists ($unids{
 316                 $self -> {cgi_object} -> param (
 317                   $self -> {conf} -> {form_data} -> {uniqueID} -> {name})})) {
 318     $self -> {error} = {
 319       spec => 'dupe',
 320       type => 'fatal'
 321     };
 322     return;
 323   }
 324
 325   # ok, looks fine
 326   1;
 327 }
 328
 329 ### sub check_cgi ##############################################################
 330 #
 331 # cgi params are like raw eggs...
 332 #
 333 # Return: Status Code (Bool)
 334 #         creates content for the handle_error method if anything fails
 335 #
 336 sub check_cgi {
 337   my $self = shift;
 338
 339   # count the submitted keys and get the keys themselves
 340   #
 341   my %got_keys     = map {($_ => 1)} $self -> {cgi_object} -> param;
 342   my $cnt_got_keys = keys %got_keys;
 343   my $formdata     = $self -> {conf} -> {form_data};
 344   my $formmust     = $self -> {conf} -> {form_must};
 345
 346   # user requested the 'new thread' page
 347   # (no params but perhaps the user-ID have been submitted)
 348   #
 349   if ($cnt_got_keys == 0 or (
 350         exists ($formdata -> {userID})
 351         and $cnt_got_keys == 1
 352         and $got_keys{$formdata -> {userID} -> {name}}
 353         )) {
 354     $self -> {response} -> {new_thread} = 1;
 355     $self -> {check_success} = 1;
 356     return 1;
 357   }
 358
 359   # now we know, we've got a filled out form
 360   # we do the following steps to check it:
 361   #
 362   # 1st: create a reverse Hash (CGI-key - identifier)
 363   # 2nd: did we get _all_ must-keys?
 364   #      check whether reply or new message request
 365   # 3rd: did we get too many keys?
 366   # 4th: do _all_ submitted values accord to
 367   #      our expectations?
 368   #      fetch the "missing" keys
 369   #
 370
 371   # 1
 372   #
 373   my %name = map {($formdata -> {$_} -> {name} => $_)} keys %$formdata;
 374
 375   # 2
 376   #
 377   $self -> {response} -> {reply} = $got_keys {$formdata -> {followUp} -> {name}}? 1 : 0;
 378   $self -> {response} -> {new}   = not $self -> {response} -> {reply};
 379
 380   # define the fetch array (values to fetch from parent message)
 381   #
 382   $self -> {fetch} = [];
 383
 384   for ( @{$formmust -> {$self -> {response} -> {reply}?'reply':'new'}} ) {
 385
 386     unless ($got_keys {$formdata -> {$_} -> {name}}) {
 387
 388       # only miss the key unless we're able to fetch it from parent posting
 389       #
 390       unless (
 391            $self -> {response} -> {new}
 392         or $formdata -> {$name {$_}} -> {errorType} eq 'fetch') {
 393
 394         $self -> {error} = {
 395           spec => 'missing_key',
 396           type => 'fatal'
 397         };
 398         return;
 399       }
 400       else {
 401         # keep in mind to fetch the value later
 402         #
 403         push @{$self -> {fetch}} => $name {$_};
 404       }
 405     }
 406   }
 407
 408   # 3
 409   #
 410   for ($self -> {cgi_object} -> param) {
 411     unless (exists ($name {$_})) {
 412       $self -> {error} = {
 413         spec => 'unexpected_key',
 414         desc => $name{$_},
 415         type => 'fatal'
 416       };
 417       return;
 418     }
 419   }
 420
 421   # 4
 422   #
 423   unless ($self -> decode_param) {
 424     $self -> {error} = {
 425       spec => 'unknown_encoding',
 426       type => 'fatal'
 427     };
 428     return;
 429   };
 430
 431   # I'm lazy - I know...
 432   my $q = $self -> {cgi_object};
 433
 434   if ($self -> {response} -> {reply}) {
 435
 436     # get the parent-identifiers if we got a reply request
 437     #
 438     my ($ftid, $fmid) = split /;/ => $q -> param ($formdata -> {followUp} -> {name}) => 2;
 439
 440     unless ($ftid =~ /\d+/ and $fmid =~ /\d+/) {
 441       $self -> {error} = {
 442         spec => 'unknown_followup',
 443         type => 'fatal'
 444       };
 445       return;
 446     }
 447     $self -> {fup_tid} = $ftid;
 448     $self -> {fup_mid} = $fmid;
 449
 450     # fetch the missing keys
 451     # if it fails, they're too short, too... ;)
 452     #
 453     $self -> fetch;
 454     $got_keys{$_}=1 for (@{$self -> {fetch}});
 455   }
 456
 457   # now we can check on length, type etc.
 458   #
 459   for (keys %got_keys) {
 460
 461     # we are sure, we've got only one value for one key
 462     #
 463     my $val = $q -> param ($_);
 464
 465     $val =~ s/\302\240/ /g;           # convert nbsp (UTF-8 encoded) into normal spaces
 466     $val =~ s/\015\012|\015|\012/ /g  # convert \n into spaces unless it's a multiline field
 467       unless (
 468         exists ($formdata -> {$name {$_}} -> {type})
 469         and $formdata -> {$name {$_}} -> {type} eq 'multiline-text'
 470       );
 471
 472     $q -> param ($_ => $val);  # write it back
 473
 474     # too long?
 475     #
 476     if (length $val > $formdata -> {$name {$_}} -> {maxlength}) {
 477       $self -> {error} = {
 478         spec => 'too_long',
 479         desc => $name{$_},
 480         type => $formdata -> {$name {$_}} -> {errorType}
 481       };
 482       return;
 483     }
 484
 485     # too short?
 486     # (only check if there's defined a minimum length)
 487     #
 488     if (exists ($formdata -> {$name {$_}} -> {minlength})) {
 489
 490       # kill the whitespaces to get only the visible characters...
 491       #
 492       (my $val_ww = $val) =~ s/\s+//g;
 493
 494       if (length $val_ww < $formdata -> {$name {$_}} -> {minlength}) {
 495         $self -> {error} = {
 496           spec => 'too_short',
 497           desc => $name{$_},
 498           type => $formdata -> {$name {$_}} -> {errorType}
 499         };
 500         return;
 501       }
 502     }
 503
 504     # check the values on expected kinds of content
 505     # (email, http-url, url)
 506     #
 507     if (exists ($formdata -> {$name {$_}} -> {type}) and length $val) {
 508       if ($formdata -> {$name {$_}} -> {type} eq 'email' and not is_email $val) {
 509         $self -> {error} = {
 510           spec => 'wrong_mail',
 511           desc => $name{$_},
 512           type => $formdata -> {$name {$_}} -> {errorType}
 513         };
 514         return;
 515       }
 516
 517       elsif ($formdata -> {$name {$_}} -> {type} eq 'http-url' and not is_URL $val => 'http') {
 518         $self -> {error} = {
 519           spec => 'wrong_http_url',
 520           desc => $name{$_},
 521           type => $formdata -> {$name {$_}} -> {errorType}
 522         };
 523         return;
 524       }
 525
 526       elsif ($formdata -> {$name {$_}} -> {type} eq 'url' and not is_URL $val => ':ALL') {
 527         $self -> {error} = {
 528           spec => 'wrong_url',
 529           desc => $name{$_},
 530           type => $formdata -> {$name {$_}} -> {errorType}
 531         };
 532         return;
 533       }
 534     }
 535   }
 536
 537   # ok, looks good.
 538   1;
 539 }
 540
 541 ### sub fetch ##################################################################
 542 #
 543 # fetch "missing" keys from parent posting
 544 #
 545 sub fetch {
 546   my $self = shift;
 547   my $q = $self -> {cgi_object};
 548   my $formdata = $self -> {conf} -> {form_data};
 549
 550   if (@{$self -> {fetch}}) {
 551     my $filename = $self -> {conf} -> {message_path}.'t'.$self -> {fup_tid}.'.xml';
 552
 553     if (lock_file ($filename)) {
 554       my $xml = parse_xml_file ($filename);
 555       violent_unlock_file($filename) unless unlock_file ($filename);
 556
 557       if ($xml) {
 558         my $mnode = get_message_node ($xml, 't'.$self -> {fup_tid}, 'm'.$self -> {fup_mid});
 559         if ($mnode) {
 560           my $header = get_message_header ($mnode);
 561
 562           $q -> param ($formdata -> {$_} -> {name} => $header -> {$formdata -> {$_} -> {header}})
 563             for (@{$self -> {fetch}});
 564
 565           return;
 566         }
 567       }
 568     }
 569   }
 570
 571   # fetching failed:
 572   # fillout the values with an empty string
 573   #
 574   $q -> param ($formdata -> {$_} -> {name} => '')
 575     for (@{$self -> {fetch}});
 576
 577   return;
 578 }
 579
 580 ### sub decode_param ###########################################################
 581 #
 582 # convert submitted form data into UTF-8
 583 # unless it's not encoded yet
 584 #
 585 # Return: Status Code (Bool)
 586 #         false if unknown encoding (like UTF-7 for instance)
 587 #
 588 sub decode_param {
 589   my $self = shift;
 590
 591   my $q = $self -> {cgi_object};
 592   my $formdata = $self -> {conf} -> {form_data};
 593
 594   my $code = $q -> param ($formdata -> {quoteChar} -> {name});
 595   my @array;
 596
 597   # Latin 1 (we hope so - there's no real way to find out :-( )
 598   if ($code =~ /^\377/) {
 599     $q -> param ($_ => map {toUTF8($_)} $q -> param ($_)) for ($q -> param);
 600   }
 601   else {
 602     # UTF-8 is (probably) correct,
 603     # other encodings we don't know and fail
 604     return unless $code =~ /^\303\277/;
 605   }
 606
 607   # remove the &#255; (encoded as UTF-8) from quotechars
 608   $q -> param ($formdata -> {quoteChar} -> {name} => substr ($code, 2));
 609
 610   # ok, params now should be UTF-8 encoded
 611   1;
 612 }
 613
 614 #
 615 #
 616 ### end of fo_posting.pl #######################################################