view release on metacpan or  search on metacpan

lib/App/MBUtiny/Collector/Server.pm  view on Meta::CPAN

    > Host: localhost
    > User-Agent: curl/7.58.0
    > Accept: */*
    >
    < HTTP/1.1 204 No Content
    < Date: Fri, 21 Jun 2019 21:40:36 GMT
    < Server: Apache/2.4.29 (Ubuntu)
    < Connection: close
    < Content-Type: text/plain
    <

=cut

__PACKAGE__->register_method( # DELETE /mbutiny/NAME
    name    => "delete",
    method  => "DELETE",
    path    => $BASE_URL_PATH_PREFIX,
    deep    => 1,
    attrs   => {
        serialize => 1,
    },
    description => "Delete file",
    code    => sub {
### CODE:
    my $self = shift;
    my $q = shift;
    my $dbi = $self->dbi;
    my $name = _get_name_from_path($self->{request_uri} // "");
    unless ($name) {
        $self->error("Incorrect path! Check backup host name");
        $self->status(0);
        return HTTP_BAD_REQUEST;
    }
    my $file = $q->param("file");
    unless ($file) {
        $self->error("Incorrect file name for delete");
        $self->status(0);
        return HTTP_BAD_REQUEST;
    }
    my $type = $q->param("type") // 0;

    $dbi->del(
        type    => $type,
        name    => $name,
        file    => $file,
        addr    => $ENV{REMOTE_ADDR},
    ) or do {
        $self->error($dbi->error());
        $self->status(0);
        return HTTP_INTERNAL_SERVER_ERROR;
    };

    return HTTP_NO_CONTENT; # HTTP RC
});

    return 1;
}

sub again {
    my $self = shift;
    $self->SUPER::again;

    # Serializer
    my $sr = new CTK::Serializer(SERIALIZE_FORMAT, attrs => SR_ATTRS);
    unless ($sr->status) {
        $self->error(sprintf("Can't create json serializer: %s", $sr->error));
        $self->{status} = 0;
    }
    $self->{sr} = $sr;

    # DBI object
    my $dbi_conf = $self->config('dbi') || {};
    $dbi_conf = {} unless is_hash($dbi_conf);
    my $dbi = new App::MBUtiny::Collector::DBI(%$dbi_conf);
    $self->log_error($dbi->error) if $dbi->error;
    $self->{dbi} = $dbi;

    return $self;
}
sub serializer {
    my $self = shift;
    return $self->{sr};
}
sub dbi {
    my $self = shift;
    return $self->{dbi};
}
sub middleware {
    my $self = shift;
    my $q = shift;

    # Check DBI connect
    if ($self->dbi->error) { # DBI checking
        $self->error($self->dbi->error);
        $self->status(0);
    }
    $self->{_time} = sprintf("%.4f", $self->tms(1))*1;
    return HTTP_INTERNAL_SERVER_ERROR unless $self->status;

    # Prepare input data
    my $meth = $self->info->{method} || "GET";
    if ($meth =~ /POST|PUT|PATCH/) {
        my $data = $q->param($meth."DATA") // $q->param('XForms:Model');
        Encode::_utf8_on($data);
        if (value($self->info("attrs"), "deserialize")) {
            my $serializer = $self->serializer;
            $self->data($serializer->deserialize($data));
            unless ($serializer->status) {
                $self->error(sprintf("Can't deserialize document: %s", $serializer->error));
                $self->status(0);
                return HTTP_INTERNAL_SERVER_ERROR;
            }
        } else {
            $self->data($data);
        }
    }

    return HTTP_OK;
}
sub response {
    my $self = shift;
    my $q = shift;
    my $rc = $self->code; # RC HTTP code (from yuor methods)
    my $head = $self->head || {}; # HTTP Headers (hashref)
    my $data = $self->data; # The working data
    my $msg = $self->message || HTTP::Status::status_message($rc) || "Unknown code";
    $data = {status => 0, error => $self->error || "Unknown error"} if !$self->status && (is_void($data) || $data eq "");
    return $self->SUPER::response unless $data && ref($data);
    return $self->SUPER::response unless value($self->info("attrs"), "serialize");
    #binmode STDOUT, ":raw:utf8"; # Disabled, by encoding reasons. See SUPER::response (utf8::encode($content))

    # Set debug time
    $data->{'time'} = sprintf("%.4f", sprintf("%.4f", $self->tms(1))*1 - $self->{_time})*1;

    # Set status and response
    $data->{status} = $self->status;
    $data->{error} = $self->error;

    # Headers
    $head->{Server} = sprintf("%s/%s", __PACKAGE__, $VERSION);
    $head->{Connection} = "close";
    $head->{Date} = HTTP::Date::time2str(time());
    $head->{'Content-Type'} = CONTENT_TYPE;
    $self->head($head);

    my $serializer = $self->serializer;
    $self->data($serializer->serialize($data));

    unless ($serializer->status) {
        my $errmsg = sprintf("Can't serialize structure: %s", $serializer->error);
        $errmsg =~ s/\"/\\\"/g;
        $errmsg =~ s/\'/\\\'/g;
        $self->data(sprintf('{"status": 0, "error": "%s"}', $errmsg));
        $self->code(HTTP_INTERNAL_SERVER_ERROR);
    }

    #my @res = (sprintf("Status: %s %s", $rc, $msg));
    #push @res, sprintf("Content-Type: %s", "text/plain; charset=utf-8");
    #push @res, "", $data // "";
    #return join("\015\012", @res);

    return $self->SUPER::response;
}

sub _get_name_from_path {
    my $request_uri = shift // '';
    my $uri = new URI(sprintf("http://localhost%s", $request_uri));
    my $str = $uri->path() // "";
    return "" unless length($str);
    return "" if index($str, $BASE_URL_PATH_PREFIX, 0);
    my $sfx = substr($str, length($BASE_URL_PATH_PREFIX)) || "";
    $sfx =~ s/^\/+//;
    $sfx =~ s/\/+/\-/g;
    return $sfx;
}

=head1 INTERNAL METHODS

=head2 again

The CTK method for classes extension

See L<CTK/again>

=head2 dbi

Returns L<App::MBUtiny::Collector::DBI> object

=head2 middleware

The L<WWW::MLite> method for input data preparing

=head2 response

The L<WWW::MLite> method for output data preparing

=head2 serializer

Returns current serializer object

See L<CTK::Serializer>

=head1 HISTORY

See C<Changes> file

=head1 TO DO

See C<TODO> file

=head1 SEE ALSO

L<App::MBUtiny>, L<WWW::MLite>, L<App::MBUtiny::Collector::DBI>

=head1 AUTHOR

Serż Minus (Sergey Lepenkov) L<http://www.serzik.com> E<lt>abalama@cpan.orgE<gt>

=head1 COPYRIGHT

Copyright (C) 1998-2019 D&D Corporation. All Rights Reserved