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