File Coverage

blib/lib/Chouette.pm

Criterion	Covered	Total	%
statement	151	249	60.6
branch	17	74	22.9
condition	4	14	28.5
subroutine	29	34	85.2
pod	1	4	25.0
total	202	375	53.8

package Chouette;

use common::sense;

use EV;
use AnyEvent;
use AnyEvent::Util;
use AnyEvent::Task::Client;
use AnyEvent::Task::Server;
use Feersum;
use Callback::Frame;
use Log::File::Rolling;
use Cwd;
use Regexp::Assemble;
use Session::Token;
use Data::Dumper;

use Chouette::Context;

our $VERSION = '0.101';



sub new {
    my ($class, $app_spec) = @_;

    my $self = {
        app_spec => $app_spec,
    };
    bless $self, $class;

    my $config = {};

    if ($app_spec->{config_file}) {
        require YAML;
        $config = YAML::LoadFile($app_spec->{config_file});
    }

    $self->{config} = {
        %{ $app_spec->{config_defaults} },
        %$config,
    };

    $self->{quiet} = $app_spec->{quiet};

    $self->_validate_config();

    $self->_compile_app();

    $self->{_done_gensym} = \'';

    return $self;
}




sub _validate_config {
    my ($self) = @_;

    die "var_dir $self->{config}->{var_dir} is not a directory" if !-e $self->{config}->{var_dir};
}


sub _compile_app {
    my ($self) = @_;

    ## Middleware

    foreach my $middleware_spec (@{ $self->{app_spec}->{middleware} }) {
        $middleware_spec = [ $middleware_spec ] if !ref($middleware_spec);
        $middleware_spec = [ @$middleware_spec ]; ## copy so don't destroy app_spec version

        my $pkg = $middleware_spec->[0];

        if ($pkg =~ m{^Plack::Middleware::}) {
            eval "require $pkg" || die "Couldn't require middleware $pkg\n\n$@";
        } else {
            if (!eval "require $pkg") {
                my $new_pkg = "Plack::Middleware::" . $pkg;
                eval "require $new_pkg" || die "Couldn't require middleware $pkg (or $new_pkg)";
                $middleware_spec->[0] = $new_pkg;
            }
        }

        push @{ $self->{middleware_specs} }, $middleware_spec;
    }


    ## Pre-route wrappers

    if (defined $self->{app_spec}->{pre_route}) {
        $self->{pre_route_cb} = $self->_load_function($self->{app_spec}->{pre_route}, "pre-route");
    }


    ## Routes

    $self->{route_regexp_assemble} = Regexp::Assemble->new->track(1);
    $self->{route_patterns} = {};

    my $routes = $self->{app_spec}->{routes};

    foreach my $route (keys %$routes) {
        my $re = '\A' . $route . '\z';

        $re =~ s{/}{\\/}g; ## Hack for Regexp::Assemble: https://github.com/ronsavage/Regexp-Assemble/issues/4

        $re =~ s{:([\w]+)}{(?<$1>[^/]+)};

        $self->{route_regexp_assemble}->add($re);

        my $methods = {};

        foreach my $method (keys %{ $routes->{$route} }) {
            $methods->{$method} = $self->_load_function($routes->{$route}->{$method}, "route: $method $route");
        }

        $self->{route_patterns}->{$re} = $methods;
    }

    $self->{route_regexp} = $self->{route_regexp_assemble}->re;


    ## Tasks

    foreach my $task_name (keys %{ $self->{app_spec}->{tasks} }) {
        die "invalid task name: $task_name" if $task_name !~ /\A\w+\z/;

        my $task = $self->{app_spec}->{tasks}->{$task_name};
        my $pkg = $task->{pkg};

        eval "require $pkg" || die "Couldn't require task package $pkg (required for task $task_name)\n\n$@";
        die "Couldn't find function new in $pkg (needed task $task_name)" if !defined &{ "${pkg}::new" };
    }
}



sub _load_function {
    my ($self, $spec, $needed_for) = @_;

    $needed_for = "(needed for $needed_for)" if defined $needed_for;

    if (ref $spec eq 'CODE') {
        return $spec;
    } elsif ($spec =~ /^(.*)::([^:]+)$/) {
        my ($pkg, $func_name) = ($1, $2);
        eval "require $pkg" || die "Couldn't require $pkg $needed_for\n\n$@";
        die "Couldn't find function $func_name in $pkg $needed_for" if !defined &{ "${pkg}::${func_name}" };
        my $func = \&{ "${pkg}::${func_name}" };
        return $func;
    } else {
        die "couldn't parse function: '$spec'";
    }
}



sub _listen {
    my ($self) = @_;

    my $listen = $self->{config}->{listen};

    my $socket;

    if ($listen =~ m{^unix:(.*)}) {
        my $socket_file = $1;

        require IO::Socket::UNIX;

        unlink($socket_file);

        $socket = IO::Socket::UNIX->new(
            Listen => 5,
            Type => IO::Socket::SOCK_STREAM(),
            Local => $socket_file,
        ) || die "unable to listen on $listen : $!";

        $self->{_friendly_socket_desc} = "http://[unix:$socket_file]";
    } else {
        my $local_addr = '0.0.0.0';
        my $port;

        if ($listen =~ m{^(.*):(\d+)$}) {
            $local_addr = $1;
            $port = $2;
        } elsif ($listen =~ m{^(\d+)$}) {
            $port = $1;
        } else {
            die "unable to parse listen param: '$listen'";
        }

        require IO::Socket::INET;

        $socket = IO::Socket::INET->new(
            Listen => 5,
            Proto => 'tcp',
            LocalAddr => $local_addr,
            LocalPort => $port,
            ReuseAddr => 1,
        ) || die "unable to listen on $listen : $!";

        $self->{_friendly_socket_desc} = "http://$local_addr:$port";
    }

    AnyEvent::Util::fh_nonblocking($socket, 1);

    $self->{accept_socket} = $socket;
}

sub _logging {
    my ($self) = @_;

    my $log_dir = "$self->{config}->{var_dir}/logs";

    if (!-e $log_dir) {
        mkdir($log_dir) || die "couldn't mkdir($log_dir): $!";
    }

    $log_dir = Cwd::abs_path($log_dir);

    my $app_name = $self->{config}->{logging}->{file_prefix} // 'app';

    my $curr_symlink = "$log_dir/$app_name.current.log";

    $self->{raw_logger} = Log::File::Rolling->new(
                              filename => "$log_dir/$app_name.%Y-%m-%dT%H.log",
                              current_symlink => $curr_symlink,
                              timezone => ($self->{config}->{logging}->{timezone} // 'gmtime'),
                          ) || die "Error creating Log::File::Rolling logger: $!";

    $self->{_friendly_current_logfile} = $curr_symlink;
}


sub _start_task_servers {
    my ($self) = @_;

    my $task_dir = "$self->{config}->{var_dir}/tasks";

    if ($self->{app_spec}->{tasks}) {
        if (!-e $task_dir) {
            mkdir($task_dir) || die "couldn't mkdir($task_dir): $!";
        }
    }

    foreach my $task_name (keys %{ $self->{app_spec}->{tasks} }) {
        my $task = $self->{app_spec}->{tasks}->{$task_name};
        my $pkg = $task->{pkg};

        my $obj;

        my $constructor_func = \&{ "${pkg}::new" };

        my $checkout_done;
        $checkout_done = \&{ "${pkg}::CHECKOUT_DONE" } if defined &{ "${pkg}::CHECKOUT_DONE" };

        AnyEvent::Task::Server::fork_task_server(
            listen => ['unix/', "$task_dir/$task_name.socket"],

            setup => sub {
                $obj = $constructor_func->($pkg, $self->{config});
            },

            interface => sub {
                my ($method, @args) = @_;
                $obj->$method(@args);
            },

            $checkout_done ? (
                checkout_done => sub {
                    $checkout_done->($obj);
                },
            ) : (),

            %{ $task->{server} },
        );
    }
}


sub _start_task_clients {
    my ($self) = @_;

    my $task_dir = "$self->{config}->{var_dir}/tasks";

    foreach my $task_name (keys %{ $self->{app_spec}->{tasks} }) {
        my $task = $self->{app_spec}->{tasks}->{$task_name};

        $self->{task_clients}->{$task_name} = AnyEvent::Task::Client->new(
            connect => ['unix/', "$task_dir/$task_name.socket"],
            %{ $task->{client} },
        );

        $self->{task_checkout_caching}->{$task_name} = 1 if $self->{app_spec}->{tasks}->{$task_name}->{checkout_caching};
    }
}



sub serve {
    my ($self) = @_;

    $self->{_serving} = 1;

    $self->_start_task_servers();
    $self->_start_task_clients();
    $self->_listen();
    $self->_logging();

    $self->{feersum} = Feersum->endjinn;
    $self->{feersum}->use_socket($self->{accept_socket});

    my $app = sub {
        my $env = shift;

        return sub {
            my $responder = shift;

            my $c = Chouette::Context->new(
                        chouette => $self,
                        env => $env,
                        responder => $responder,
                    );

            $self->_handle_request($c);
        };
    };

    foreach my $middleware_spec (@{ $self->{middleware_specs} }) {
        my @s = @$middleware_spec;
        my $pkg = shift(@s);
        $app = $pkg->wrap($app, @s);
    }

    $self->{feersum}->psgi_request_handler($app);

    return if $self->{quiet};

    say "="x79;
    say;
    say "Chouette $VERSION";
    say;
    say "PID = $$";
    say "UID/GIDs = $
    say "Listening on: $self->{_friendly_socket_desc}";
    say;
    say "Follow log messages:";
    say "    log-defer-viz -F $self->{_friendly_current_logfile}";
    say;
    say "="x79;
}


sub run {
    my ($self) = @_;

    $self->serve unless $self->{_serving};

    AE::cv->recv;
}


sub _handle_request {
    my ($self, $c) = @_;

    my $req = $c->req;
    $c->logger->info("Request from " . $req->address . " : " . $req->method . " " . $req->path);

    frame_try {
        if ($self->{pre_route_cb}) {
            my $pre_route_cb = fub { $self->{pre_route_cb}->(@_) };
            $pre_route_cb->($c, fub { $self->_do_routing($c) });
        } else {
            $self->_do_routing($c);
        }
    } frame_catch {
        my $err = $@;

        return if ref($err) && ($err + 0 == $c->{chouette}->{_done_gensym} + 0);

        if ($err =~ /^(\d\d\d)\b(?:\s*:\s*)?(.*)/) {
            my $status = $1;
            my $msg = $2;

            my $body = {};

            if ($status < 200 || $status >= 400) {
                $c->logger->warn("threw $err");
                if (length($msg)) {
                    $msg =~ s/ at \S+ line \d+\.$//;
                    $body->{error} = $msg;
                } else {
                    $msg = "HTTP code $status";
                }
            } else {
                $msg =~ s/ at \S+ line \d+\.$//;
                $body->{ok} = $msg;
            }

            $c->respond($body, $status);
            return;
        }

        $c->logger->error($err);
        $c->logger->data->{stacktrace} = $_[0];

        $c->respond({ error => 'internal server error' }, 500);
    };
}


sub _do_routing {
    my ($self, $c) = @_;

    my $path = $c->{env}->{PATH_INFO};
    $path = '/' if $path eq '';

    die "404: Not Found" unless $path =~ $self->{route_regexp};

    my $route_params = \%+;

    my $methods = $self->{route_patterns}->{ $self->{route_regexp_assemble}->source($^R) };

    my $method = $c->{env}->{REQUEST_METHOD};

    my $func = $methods->{$method};

    die "405: Method Not Allowed" if !$func;

    $c->{route_params} = $route_params;

    $func->($c);
}



sub generate_token {
    state $generator = Session::Token->new;

    return $generator->get;
}

1;



__END__