<commit_before>package Smeagol::Server;

use strict;
use warnings;

use base qw(Exporter HTTP::Server::Simple::CGI);
use CGI qw();
use Carp;
use Smeagol::DataStore;
use Encode;
use HTTP::Status qw(:constants status_message);
use Smeagol::Server::Handler
    qw(listResources retrieveResource deleteResource updateResource createResource listBookings listBookingsIcal createBooking createTag listTags deleteTag retrieveBooking updateBooking deleteBooking retrieveBookingIcal);
use POSIX ();

our @EXPORT_OK = qw(send_xml send_error send_ical);

my $REQUEST_TIMEOUT = 60;
my $VERBOSE_MODE;    # server logs disabled by default

# Don't die on SIGALRM, don't do anything, just stop sysreading
$SIG{ALRM} = sub { };

sub accept_hook {

    # First, let the parent do its magic
    shift->SUPER::accept_hook(@_);

    # Then, start timer for lazy requests
    alarm($REQUEST_TIMEOUT);
}

sub post_setup_hook {

    # Stop timer for lazy requests
    alarm(0);

    # Then do as parent says
    shift->SUPER::post_setup_hook(@_);
}

# Constructor needs two arguments: port to listen to, and datastore full path.
# For example:
#    Smeagol::Server->new( 8000, datastorepath => '/tmp/smeagol_datastore' );
sub new {
    my $class = shift;
    my ( $port, %args ) = @_;

    Smeagol::DataStore::init( $args{'datastorepath'} );
    $REQUEST_TIMEOUT = $args{'timeout'} if defined $args{'timeout'};
    $VERBOSE_MODE = $args{'verbose'};

    my $obj = $class->SUPER::new($port);

    bless $obj, $class;
    return $obj;
}

sub print_banner {

    # dummy banner which prints nothing, because parent class's is buggy
    # (always shows a "listening on http://localhost..." message)
}

# Nota: hauria de funcionar amb "named groups" però només
# s'implementen a partir de perl 5.10. Quina misèria, no?
# A Python fa temps que funcionen...
#
# Dispatcher table. Associates a handler to an URL. Groups in
# the URL pattern are given as parameters to handler.
my %crud_for = (
    '/resources'      => { GET => \&listResources, },
    '/resource/(\d+)' => {
        GET    => \&retrieveResource,
        DELETE => \&deleteResource,
        POST   => \&updateResource,
    },
    '/resource'                        => { POST   => \&createResource, },
    '/resource/(\d+)/bookings'         => { GET    => \&listBookings, },
    '/resource/(\d+)/bookings/ical'    => { GET    => \&listBookingsIcal, },
    '/resource/(\d+)/booking'          => { POST   => \&createBooking, },
    '/resource/(\d+)/tag'              => { POST   => \&createTag, },
    '/resource/(\d+)/tags'             => { GET    => \&listTags, },
    '/resource/(\d+)/tag/([\w.:_\-]+)' => { DELETE => \&deleteTag, },
    '/resource/(\d+)/booking/(\d+)'    => {
        GET    => \&retrieveBooking,
        POST   => \&updateBooking,
        DELETE => \&deleteBooking,
    },
    '/resource/(\d+)/booking/(\d+)/ical' => { GET => \&retrieveBookingIcal },
    '/css/(\w+)\.css'                    => { GET => \&_send_css },
    '/dtd/(\w+)\.dtd'                    => { GET => \&_send_dtd },
    '/xsl/(\w+)\.xsl'                    => { GET => \&_send_xsl },
    '/'                                  => {
        GET => sub { _send_html( $_[0], "server" ) }
    },
);

# Http request dispatcher. Sends every request to the corresponding
# handler according to hash %crud_for. The handler receives
# the CGI object and the list of parameters acording to the corresponding
# groups in the %crud_for regular expressions.
sub handle_request {
    my $self = shift;
    my $cgi  = shift;

    my $path_info = $cgi->path_info();
    my $method    = $cgi->request_method();

    # Find the corresponding action
    my $url_key = 'default_action';
    my @ids;

    foreach my $url_pattern ( keys(%crud_for) ) {

        # Anchor pattern and allow URLs ending in '/'
        my $pattern = '^' . $url_pattern . '/?$';
        if ( $path_info =~ m{$pattern} ) {
            @ids = ( $1, $2 );
            $url_key = $url_pattern;
            last;
        }
    }

    # Dispatch to the corresponding action.
    # Pass parameters obtained from the pattern to action
    if ( exists $crud_for{$url_key} ) {
        if ( exists $crud_for{$url_key}->{$method} ) {
            $crud_for{$url_key}->{$method}->( $cgi, $ids[0], $ids[1] );
        }
        else {

            # Requested HTTP method not available
            send_error(HTTP_METHOD_NOT_ALLOWED);
        }
    }
    else {

        # Requested URL not available
        send_error(HTTP_NOT_FOUND);
    }

    _log_request( $method, $cgi ) if $VERBOSE_MODE;
}

# _log_request(method, cgi):
#       generate log messages conforming to Apache Combined Log format,
#       as defined in http://httpd.apache.org/docs/2.2/logs.html#accesslog
#       FIXME: Several fields have a hard-coded "-" value (i.e. user ident,
#              user ID and response object size).
sub _log_request {
    my ( $method, $cgi ) = @_;
    my $strDate = POSIX::strftime( "%d/%b/%Y:%H:%M:%S - %z", localtime() );
    my $rhost   = $cgi->remote_host();
    my $uri     = $cgi->request_uri();
    my $proto
        = defined( $cgi->server_protocol() )
        ? uc( $cgi->server_protocol() )
        : "-";
    my $referer = defined( $cgi->referer() )    ? $cgi->referer()    : "-";
    my $ua      = defined( $cgi->user_agent() ) ? $cgi->user_agent() : "-";

    print STDERR
        "$rhost - - [$strDate] \"$method $uri $proto\" - \"$referer\" \"$ua\"\n";
}

#############################################################
# Http tools
#############################################################

sub _reply {
    my ( $status, $type, $text ) = @_;

    croak "wrong number of parameters"
        if @_ < 2;

    my $msg = status_message($status);
    croak "unknown status code $status"
        unless defined $msg;

    $text = $msg
        unless defined $text;

    print "HTTP/1.0 $status $msg\n", CGI->header($type), $text, "\n";
    return $status;
}

# Prints an Http response. Message is optional.
sub send_error {
    my ( $status, $text ) = @_;

    #<commit_msg> * Merged branch ticket133_r613 (r613:619) into the trunk.  * Closes: #133<commit_after>package Smeagol::Server;

use strict;
use warnings;

use base qw(Exporter HTTP::Server::Simple::CGI);
use CGI qw();
use Carp;
use Smeagol::DataStore;
use Encode;
use HTTP::Status qw(:constants status_message);
use Smeagol::Server::Handler
    qw(listResources retrieveResource deleteResource updateResource createResource listBookings listBookingsIcal createBooking createTag listTags deleteTag retrieveBooking updateBooking deleteBooking retrieveBookingIcal);
use POSIX ();

our @EXPORT_OK = qw(send_xml send_error send_ical);

my $REQUEST_TIMEOUT = 60;
my $VERBOSE_MODE;    # server logs disabled by default

# Don't die on SIGALRM, don't do anything, just stop sysreading
$SIG{ALRM} = sub { };

sub accept_hook {

    # First, let the parent do its magic
    shift->SUPER::accept_hook(@_);

    # Then, start timer for lazy requests
    alarm($REQUEST_TIMEOUT);
}

sub post_setup_hook {

    # Stop timer for lazy requests
    alarm(0);

    # Then do as parent says
    shift->SUPER::post_setup_hook(@_);
}

# Constructor needs two arguments: port to listen to, and datastore full path.
# For example:
#    Smeagol::Server->new( 8000, datastorepath => '/tmp/smeagol_datastore' );
sub new {
    my $class = shift;
    my ( $port, %args ) = @_;

    Smeagol::DataStore::init( $args{'datastorepath'} );
    $REQUEST_TIMEOUT = $args{'timeout'} if defined $args{'timeout'};
    $VERBOSE_MODE = $args{'verbose'};

    my $obj = $class->SUPER::new($port);

    bless $obj, $class;
    return $obj;
}

sub print_banner {

    # dummy banner which prints nothing, because parent class's is buggy
    # (always shows a "listening on http://localhost..." message)
}

# Nota: hauria de funcionar amb "named groups" però només
# s'implementen a partir de perl 5.10. Quina misèria, no?
# A Python fa temps que funcionen...
#
# Dispatcher table. Associates a handler to an URL. Groups in
# the URL pattern are given as parameters to handler.
my %crud_for = (
    '/resources'      => { GET => \&listResources, },
    '/resource/(\d+)' => {
        GET    => \&retrieveResource,
        DELETE => \&deleteResource,
        POST   => \&updateResource,
    },
    '/resource'                        => { POST   => \&createResource, },
    '/resource/(\d+)/bookings'         => { GET    => \&listBookings, },
    '/resource/(\d+)/bookings/ical'    => { GET    => \&listBookingsIcal, },
    '/resource/(\d+)/booking'          => { POST   => \&createBooking, },
    '/resource/(\d+)/tag'              => { POST   => \&createTag, },
    '/resource/(\d+)/tags'             => { GET    => \&listTags, },
    '/resource/(\d+)/tag/([\w.:_\-]+)' => { DELETE => \&deleteTag, },
    '/resource/(\d+)/booking/(\d+)'    => {
        GET    => \&retrieveBooking,
        POST   => \&updateBooking,
        DELETE => \&deleteBooking,
    },
    '/resource/(\d+)/booking/(\d+)/ical' => { GET => \&retrieveBookingIcal },
    '/css/(\w+)\.css'                    => { GET => \&_send_css },
    '/dtd/(\w+)\.dtd'                    => { GET => \&_send_dtd },
    '/xsl/(\w+)\.xsl'                    => { GET => \&_send_xsl },
    '/'                                  => {
        GET => sub { _send_html( $_[0], "server" ) }
    },
);

# Http request dispatcher. Sends every request to the corresponding
# handler according to hash %crud_for. The handler receives
# the CGI object and the list of parameters acording to the corresponding
# groups in the %crud_for regular expressions.
sub handle_request {
    my $self = shift;
    my $cgi  = shift;

    my $path_info = $cgi->path_info();
    my $method    = $cgi->request_method();

    # Find the corresponding action
    my $url_key = 'default_action';
    my @ids;

    foreach my $url_pattern ( keys(%crud_for) ) {

        # Anchor pattern and allow URLs ending in '/'
        my $pattern = '^' . $url_pattern . '/?$';
        if ( $path_info =~ m{$pattern} ) {
            @ids = ( $1, $2 );
            $url_key = $url_pattern;
            last;
        }
    }

    # Dispatch to the corresponding action.
    # Pass parameters obtained from the pattern to action
    if ( exists $crud_for{$url_key} ) {
        if ( exists $crud_for{$url_key}->{$method} ) {
            $crud_for{$url_key}->{$method}->( $cgi, $ids[0], $ids[1] );
        }
        else {

            # Requested HTTP method not available
            send_error(HTTP_METHOD_NOT_ALLOWED);
        }
    }
    else {

        # Requested URL not available
        send_error(HTTP_NOT_FOUND);
    }

    _log_request( $method, $cgi ) if $VERBOSE_MODE;
}

# _log_request(method, cgi):
#       generate log messages conforming to Apache Combined Log format,
#       as defined in http://httpd.apache.org/docs/2.2/logs.html#accesslog
#       FIXME: Several fields have a hard-coded "-" value (i.e. user ident,
#              user ID and response object size).
sub _log_request {
    my ( $method, $cgi ) = @_;
    my $strDate = POSIX::strftime( "%d/%b/%Y:%H:%M:%S %z", localtime() );
    my $rhost   = $cgi->remote_host();
    my $uri     = $cgi->request_uri();
    my $proto
        = defined( $cgi->server_protocol() )
        ? uc( $cgi->server_protocol() )
        : "-";
    my $referer
        = defined( $cgi->referer() ) ? q["] . $cgi->referer() . q["] : '-';
    my $ua
        = defined( $cgi->user_agent() )
        ? q["] . $cgi->user_agent() . q["]
        : '-';

    print STDERR
        "$rhost - - [$strDate] \"$method $uri $proto\" - - $referer $ua\n";
}

#############################################################
# Http tools
#############################################################

sub _reply {
    my ( $status, $type, $text ) = @_;

    croak "wrong number of parameters"
        if @_ < 2;

    my $msg = status_message($status);
    croak "unknown status code $status"
        unless defined $msg;

    $text = $msg
        unless defined $text;

    print "HTTP/1.0 $status $msg\n", CGI->header($type), $text, "\n";
    return $status;
}

# Prints an Http response. Message is optional.
sub send_error {
    my ( $status, $text ) = @_;

    #
{'fraction_non_alphanumeric': 0.17447575360419398, 'fraction_numerical': 0.00450524246395806, 'mean_word_length': 2.5113603681334484, 'pattern_counts': {'":': 0, '<': 5, '<?xml version=': 0, '>': 109, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 2}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 2, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3179584', 'n_tokens_mistral': 4101, 'n_tokens_neox': 3946, 'n_words': 1031}