4chan clone bbs.cgi

gistfile1.pl

#!/usr/bin/perl
use strict;
use warnings;
use utf8;

package CGI::Four::Register;
use Mouse;
use CGI::Carp qw( fatalsToBrowser );
use CGI::Minimal;
use FindBin;
use DBI;
use SQL::Abstract::Limit;
use Image::Magick;
use Encode;
use Time::Piece;


# -----------

has 'db_name' => ( is => 'rw', isa => 'Str', );

has 'db_port' => ( is => 'rw', isa => 'Int', );

has 'db_user' => ( is => 'rw', isa => 'Str', );

has 'log_table' => ( is => 'rw', isa => 'Str', );

# -----------

has 'max_thread' => ( is      => 'rw',
                      isa     => 'Int',
                      default => 1000, );

has 'max_comment' => ( is      => 'rw',
                       isa     => 'Int',
                       default => 50, );

has 'base_uri' => ( is => 'rw', isa => 'Str', );

has 'master_key' => ( is => 'rw', isa => 'Str', );

has 'cgi_name' => ( is      => 'rw',
                    isa     => 'Str',
                    default => 'read.cgi', );

has 'image_dir' => ( is      => 'rw',
                     isa     => 'Str',
                     default => 'image', );

has 'thumb_dir' => ( is      => 'rw',
                     isa     => 'Str',
                     default => 'thumb', );

has 'max_post_size' => ( is      => 'rw',
                         isa     => 'Int',
                         default => 5 * 1024 * 1024, );

has 'max_message_length' => ( is      => 'rw',
                              isa     => 'Int',
                              default => 1024, );

has 'interval_limit' => ( is      => 'rw',
                          isa     => 'Int',
                          default => 3 * 60, );

has 'thumb_geometry' => ( is      => 'rw',
                          isa     => 'Int',
                          default => 126, );

sub get_query {
  my $self = shift;

  CGI::Minimal::reset_globals();
  CGI::Minimal::max_read_size( $self->max_post_size );
  my $q = CGI::Minimal->new;

  if ( $q->truncated ) {
    my $too_large =qq| This file is too large. |;
    $self->error_message( $too_large );
    exit;
  }

  if( $q->param( 'request' ) eq 'DEL' ) {

    my $id = $q->param( 'id' );
    my $delete_key = $q->param( 'del_pass' );

    unless ( $delete_key  =~ /[0-9a-zA-Z]+/ ) {

      my $no_multibyte = "This password could not be received. $delete_key";
      $self->error_message( $no_multibyte );

    } else {
      $delete_key = decode( 'utf8', $q->htmlize( $delete_key ) );

      $self->delete_message( $id, $delete_key );
      my $location = $self->base_uri . $self->cgi_name;
      print "Location: " . $location . "\n\n";
    }

  } elsif ( ( $q->param( 'MESSAGE' ) ne '' ) &&
              ( $q->param( 'MESSAGE' ) =~ /\S/ ) ) {

    my @values = ( $q->param( 'FROM' ),
                   $q->param( 'mail' ),
                   $q->param( 'subject' ),
                   $q->param( 'MESSAGE' ),
                   $q->param( 'pwd' ), );
    foreach my $value ( @values ) {
      my $tmp_value = decode( 'utf8', $value );
      $value = $q->htmlize( $tmp_value );
    }
    my ( $name, $mail, $subject, $message, $password ) = @values;

    my $length = length( $message );
    if ( $length <= $self->max_message_length ) {

      if ( $name eq '' ) {
        $name = 'Anonymous';
      } elsif ( $name =~ /(#.{4,})/ ) {
        my $tripkey = $1;
        my $tripcode = $self->tripcode( $tripkey );
        $name =~ s/$tripkey/!$tripcode/;
      }

      $message = $self->link_check( $message );

      # get hostname from ip.
      my $ip = $ENV{'REMOTE_ADDR'};
      my $hostname = $self->get_host_by_addr( $ip );

      # interval check
      if ( ( $hostname eq '' ) ||
             ( $self->check_interval( $hostname ) ) ) {
        my $short = 'There is no hurry!';
        $self->error_message( $short );
        exit;
      }

      # file upload check
      my ( $img_path, $thumb_path, $img_size, $img_geometry );
      if ( $q->param_filename( 'upfile' ) ) {
        ( $img_path, $thumb_path, $img_size, $img_geometry )
          = $self->upload_process( $q );
      }

      my $key = $q->param( 'key' );

      $self->register( $key, $name, $mail, $subject, $message, $password,
                       $img_path, $thumb_path, $img_size, $img_geometry,
                       $ip, $hostname );
      $self->update_com_number( $key ) if $key ne '';

      my $location = $self->base_uri . $self->cgi_name;
      print "Location: $location\n\n";
      exit;

    } else {
      my $too_long = "Perhaps your message's length is too long.";
      $self->error_message( $too_long );
      exit;
    }

  } else {
    my $location = $self->base_uri . $self->cgi_name;
    print "Location: $location\n\n";
    exit;
  }

}

sub check_interval {
  my ( $self, $hostname ) = @_;

  my $dbh = $self->connect_sql;

  my $table_name = $self->log_table;
  my $req = qq| SELECT date FROM $table_name |;
  $req .= qq| WHERE hostname = ? ORDER BY id DESC LIMIT 1 |;

  if ( my $date_arry_ref = $dbh->selectrow_arrayref( $req, undef, $hostname ) ) {
    my ( $date ) = @$date_arry_ref;

    $date = encode( 'utf8', $date );

    my $t = Time::Piece->strptime( decode( 'utf8', $date ), "%FT%T" );
    my $unix_time = $t->strftime( '%s' );

    my $current_unix_time = time;
    my $diff = $current_unix_time - $unix_time;

    if ( $diff > $self->interval_limit ) {
      return 0;
    } else {
      return 1;
    }

  } else {
    return 0;
  }
}

sub update_com_number {
  my ( $self, $key ) = @_;

  my $id = int( $key );
  my $unix_time = time();

  my $table_name = $self->log_table;
  my $req = qq| UPDATE $table_name SET com_num = com_num +1, |;
  $req .= qq| update_utime = ? WHERE id = ? |;
  my $dbh = $self->connect_sql;
  my $sth = $dbh->prepare( $req );
  $sth->execute( $unix_time, $id );

  $dbh->disconnect;

  return 0;
}

sub tripcode {
  my ($self, $tripkey) = @_;

  # Wikipedia http://is.gd/BxNSsL
  $tripkey = substr( $tripkey, 1 );
  my $salt = substr( $tripkey.'H.', 1, 2 );
  $salt =~ s/[^\.-z]/\./go;
  $salt =~ tr/:;<=>?@[\\]^_`/ABCDEFGabcdef/;
  my $trip = crypt( $tripkey, $salt );
  $trip = substr( $trip, -10 );

  return $trip;
}

sub delete_message {
  my ( $self, $id, $delete_key ) = @_;

  my $dbh = $self->connect_sql;

  my $table_name = $self->log_table;
  my $req = qq| SELECT delete_key FROM $table_name WHERE id = ? LIMIT 1 |;
  my $del_key_ref = $dbh->selectrow_arrayref( $req, undef, $id );
  my ( $del_key ) = @$del_key_ref;

  if ( ( $delete_key eq $del_key )
         || ( $delete_key eq $self->master_key ) ) {

    my $sqla = SQL::Abstract->new;

    my %where = ( -or => { id => $id, reply_to => $id, }, );
    my @fields = qw/ img_path thumb_path /;

    my ( $stmt, @bind ) = $sqla->select( $self->log_table, \@fields, \%where );
    my $sth = $dbh->prepare( $stmt );
    $sth->execute( @bind );

    while ( my $arry_ref = $sth->fetchrow_arrayref ) {
      my ( $image_path, $thumb_path ) = @$arry_ref;

      my $full_path = $FindBin::Bin . '/' . $image_path;

      if ( $image_path ne '' ) {
        unless ( unlink $full_path ) {
          my $failure = "Could not delete this post. : $image_path ";
          $self->error_message( $failure );
          exit;
        } else {
          my $full_thumb_path = $FindBin::Bin . '/' . $thumb_path;
          unlink $full_thumb_path;
        }
      }
    }

    my ( $stmt2, @bind2 ) = $sqla->delete( $self->log_table, \%where );
    $sth = $dbh->prepare( $stmt2 );
    $sth->execute( @bind2 );

    $dbh->disconnect;

    return 0;

  } else {

    my $incorrect = qq| Your password would be incorrect. : $delete_key |;
    $self->error_message( $incorrect );
    exit;

  }
}


sub upload_process {
  my ( $self, $q ) = @_;

  my $file_name = $q->param( 'upfile' );
  my $mime = $q->param_mime( 'upfile' );

  my $extension;
  if ( $mime =~ /((gif|jpeg|png))$/ ) {

    $extension = $1;
    $extension =~ s/jpeg/jpg/;

  } else {

    my $not_image = 'This would not be an image file.';
    $self->error_message( $not_image );
    exit;

  }

  my $unix_time = time();
  my $upfile_name = $unix_time . '.' . $extension;
  my $save_image_path =
    $FindBin::Bin . '/' . $self->image_dir . '/' . $upfile_name;
  my $save_thumb_path =
    $FindBin::Bin . '/' . $self->thumb_dir . '/' . $upfile_name;

  # upload
  my $ok = $self->upload( $file_name, $save_image_path );

  if ( $ok ) {
    my $size;
    $size = -s $save_image_path;

    my $thread_image = 0;
    $thread_image = 1 if $q->param( 'key' ) eq '';

    my ( $convert, $img_geometry )
      = $self->make_thumb( $save_image_path, $save_thumb_path, $thread_image );

    my $i_path = $self->image_dir . '/' . $upfile_name;
    my $t_path = $self->thumb_dir . '/' . $upfile_name;

    $t_path = $i_path if $convert == 0;

    return ( $i_path, $t_path, $size, $img_geometry );
  } else {
    my $failure = 'Failed at uploading.';
    $self->error_message( $failure );
  }
}

sub upload {
  my ( $self, $file_name, $save_path ) = @_;

  if ( open UPLOAD, "+> $save_path" ) {
    binmode( UPLOAD );
    print UPLOAD $file_name;
    close UPLOAD;

    chmod( 0666, $save_path );

    return 1;
  } else {
    return 0;
  }
}

sub make_thumb {
  my ( $self, $save_image_path, $save_thumb_path, $thread_image ) = @_;

  my $image = Image::Magick->new;
  $image->Read( $save_image_path );

  # my $width = $image->Get( 'width' );
  # my $height = $image->GetPixels( 'height' );
  my ( $width, $height ) = $image->Get('width', 'height');

  my $thumb_geometry = $self->thumb_geometry;
  $thumb_geometry = $thumb_geometry * 2
    if $thread_image == 1;

  my ( $thumb_width, $thumb_height, $convert );
  if ( ( $width > $height ) && ( $width > $thumb_geometry ) ) {

    my $ratio = $thumb_geometry / $width;
    $thumb_width = $thumb_geometry;
    $thumb_height = int( $height * $ratio );
    $convert = 1;

  } elsif ( ( $width < $height ) && ( $height > $thumb_geometry ) ) {

    my $ratio = $thumb_geometry / $height;
    $thumb_height = $thumb_geometry;
    $thumb_width = int( $width * $ratio );
    $convert = 1;

  } elsif ( ( $width == $height ) && ( $width > $thumb_geometry ) ) {

    $thumb_width = $thumb_geometry;
    $thumb_height = $thumb_geometry;
    $convert = 1;

  } else {
    $thumb_width = $width;
    $thumb_height = $height;
    $convert = 0;
  }

  my $geometry = $width . 'x' . $height;
  if ( $convert == 1 ) {

    $image->Resize( width => $thumb_width, height => $thumb_height );
    $image->Comment( "" );
    $image->Write( $save_thumb_path );

    return ( $convert, $geometry );

  } else {

    return ( $convert, $geometry );

  }
}

sub get_host_by_addr {
  my ( $self, $ip ) = @_;

  my @addr = split(/\./, $ip);
  my $packed_ip = pack("C4", $addr[0], $addr[1], $addr[2], $addr[3]);
  my $hostname = gethostbyaddr($packed_ip, 2);

  return $hostname;
}

sub link_check {
  my ( $self, $message ) = @_;

  if ( $message =~ /(?<!\]\()https?:\/\/.+/i ) {

    my $caution = 'This cgi does not permit any link.';
    $self->error_message( $caution );
    exit;

  } else {

    # ttp to http
    $message =~ s/(?<!h)(ttps?:\/\/[0-9A-Za-z\/\.\?=_-]+)/<a href="h$1">h$1<\/a>/g;

    return $message;
  }
}

sub error_message {
  my ( $self, $text ) = @_;

  my $location = $self->base_uri . $self->cgi_name;

  $text = qq| <html><body><div style="text-align: center"><h1> $text </h1> |;
  $text .= qq| <p><a href="$location">Back</a></p></div></body></html> |;

  print "Content-Type: text/html; charset=UTF-8\n\n";
  print encode( 'utf8', $text );
}

sub connect_sql {
  my $self = shift;

  my $db_name = $self->db_name;
  my $db_port = $self->db_port;
  my $pg_user = $self->db_user;

  my $dbh = DBI->connect( "dbi:Pg:dbname=$db_name;port=$db_port",
                          $pg_user,
                          '',
                          { RaiseError => 1,
                            pg_enable_utf8 => 1, } )
    || die "Database Connection Error: $!";

  return $dbh;
}

sub register {
  my ( $self, @values ) = @_;

  my ( $key, $name, $mail, $subject, $message, $password,
       $img_path, $thumb_path, $img_size, $img_geometry,
       $ip, $hostname ) = @values;

  my $date = $self->get_date;
  my $unix_time = time();

  $key = 0 if $key eq '';

  my %fieldvals = ( date         => $date,
                    name         => $name,
                    mail         => $mail,
                    subject      => $subject,
                    message      => $message,
                    img_path     => $img_path,
                    thumb_path   => $thumb_path,
                    img_size     => $img_size,
                    img_geometry => $img_geometry,
                    update_utime => $unix_time,
                    delete_key   => $password,
                    com_num      => 0,
                    reply_to     => int( $key ),
                    ip           => $ip,
                    hostname     => $hostname, );

  my $dbh = $self->connect_sql;

  my $sqla = SQL::Abstract->new;
  my ( $stmt, @bind ) = $sqla->insert( $self->log_table, \%fieldvals );

  my $sth = $dbh->prepare( $stmt );
  $sth->execute( @bind );

  $dbh->disconnect;
}

sub get_date {
  my $self = shift;

  my $t = Time::Piece::localtime();
  my $date = $t->strftime( '%FT%T' );

  return $date;
}


# ------------

package main;

my $conf_file = './.conf';
my $conf = do $conf_file
  or die qq/Can't load config file "$conf_file": $!$@/;

my $register = CGI::Four::Register->new( db_name    => $conf->{ db_name },
                                         db_port    => $conf->{ db_port },
                                         db_user    => $conf->{ db_user },
                                         cgi_name   => $conf->{ cgi_name },
                                         log_table  => $conf->{ log_table },
                                         master_key => $conf->{ master_key },
                                         base_uri   => $conf->{ base_uri }, );

$register->get_query;
exit;


# last modified: 2012-01-03 01:42+09:00.