view release on metacpan or  search on metacpan

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

    $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;