—

              
package WWW::MLite; # $Id: MLite.pm 50 2019-06-21 21:05:37Z minus $
use strict;
use utf8;
HideShow 453 lines of Pod
=encoding utf-8
=head1 NAME
WWW::MLite - Lite Web Application Framework
=head1 VERSION
Version 2.01
=head1 SYNOPSIS
    package MyApp;
    use base qw/WWW::MLite/;
    use HTTP::Status qw/:constants/;
    use Data::Dumper;
    __PACKAGE__->register_method( # GET /myapp
        name    => "getIndex",
        description => "Index page",
        method  => "GET",
        path    => "/myapp",
        deep    => 0,
        attrs   => {
                foo         => 'blah-blah-blah',
                bar         => 'on',
                deserialize => 0,
                serialize   => 1,
            },
        requires => undef,
        returns => undef,
        code    => sub {
        my $self = shift;
        my @params = @_;
        $self->data(Dumper({
                params => [@params],
                name   => $self->name,
                description => $self->info("description"),
                attrs  => $self->info("attrs"),
                path   => $self->info("path"),
                method => $self->info("method"),
                requires => $self->info("requires"),
                returns => $self->info("returns"),
            }));
        return HTTP_OK; # HTTP RC
    });
    1;
    package main;
    use FindBin qw/$Bin/;
    use lib "$Bin/../lib";
    use CGI;
    use File::Spec;
    my $q = new CGI;
    my $server = MyApp->new(
        project     => "MyApp",
        ident       => "myapp",
        root        => File::Spec->catdir($Bin, "conf"),
        #confopts    => {... Config::General options ...},
        configfile  => File::Spec->catfile($Bin, "conf", "myapp.conf"),
        log         => "on",
        logfd       => fileno(STDERR),
        #logfile     => '/path/to/log/file.log',
        nph         => 0, # NPH (no-parsed-header)
    );
    print $server->call($q->request_method, $q->request_uri, $q) or die($server->error);
=head1 DESCRIPTION
Lite Web Application Framework
This module allows you to quickly and easily write a REST servers
=head2 new
    my $server = MyApp->new(
        project     => "MyApp",
        ident       => "myapp",
        root        => File::Spec->catdir($Bin, "conf"),
        #confopts    => {... Config::General options ...},
        configfile  => File::Spec->catfile($Bin, "conf", "myapp.conf"),
        log         => "on",
        logfd       => fileno(STDERR),
        #logfile     => '/path/to/log/file.log',
        nph         => 0, # NPH (no-parsed-header)
    );
Returns CTK object as WWW::MLite server
=over 4
=item confopts
Optional value. L<Config::General> options
=item configfile
File of configuration
Default: /etc/myapp/myapp.conf
=item log
General switch for logging enable/disable
Default: off
Also see configuration for logging manage
=item logfd
File descriptor or fileno
Default: none (use syslog)
See L<IO::Handle>
=item logfile
Log file path. Not recommended!
=item nph
Enable or disable NPH mode (no-parsed-header)
Default: 0
See L<CGI/USING-NPH-SCRIPTS>
This option for the response subroutine only!
=item root
Root directory for project. This is NOT document root directory!
Default: /etc/myapp
=back
See also L<CTK> and L<CTK::App>
=head1 METHODS
List of available methods
=head2 call
See L</call_method>
=head2 call_method
    $server->call_method( $ENV{REQUEST_URI}, $ENV{REQUEST_METHOD}, ... );
Runs the callback function from current method with additional parameters
Note: any number of parameters can be specified,
all of them will be receive in the callback function and in your overridden the response subroutine
Returns: response content
=head2 check_http_method
    $server->check_http_method("GET"); # returns 1
    $server->check_http_method("OPTIONS"); # returns 0
Checks the availability of the HTTP method by its name and returns the status
=head2 code
    my $code = $server->code;
    my $code = $server->code( 500 );
Gets/Sets response HTTP code
Default: 200 (HTTP_OK)
See L<HTTP::Status>
=head2 cleanup
    $server->cleanup;
Cleans the all working data and resets it to default values
=head2 data
    my $data = $server->data;
    $server->data({
            param1 => "new value",
        });
Gets/Sets working data structure or HTTP content
Default: undef
See L<HTTP::Response>
=head2 head
    my $head = $server->head;
    $server->head({
            "Content-Type" => "text/plain",
        });
Gets/Sets HTTP headers
Default: "text/plain"
See L<HTTP::Headers>
=head2 info
    my $info = $server->info;
    my $description => $server->info("description");
    my $attrs = $server->info("attrs");
    my $path = $server->info("path");
    my $method = $server>info("method");
    my $requires = $server->info("requires");
    my $returns = $server->info("returns");
Returns the info structure or info-data of current method
=head2 lookup_method
    my $method = $server->lookup_method($ENV{REQUEST_URI}, $ENV{REQUEST_METHOD});
Returns $method structure from hash of registered methods; or undef if method is not registered
=head2 message
    my $message = $server->message;
    my $message = $server->message( "Internal Server Error" );
Gets/Sets response HTTP message
Default: "OK"
See L<HTTP::Status>
=head2 name
    my $name = $server->name;
Returns name of current method. Default: default
=head2 register_method
    use base qw/WWW::MLite/;
    use HTTP::Status qw/:constants/;
    use Data::Dumper;
    __PACKAGE__->register_method( # GET /myapp
        name    => "getIndex",
        description => "Index page",
        method  => "GET",
        path    => "/myapp",
        deep    => 0,
        attrs   => {
                foo         => 'blah-blah-blah',
                bar         => 'on',
                deserialize => 0,
                serialize   => 1,
            },
        requires => [
                qw/ user1 user2 userX /
            ],
        returns => {
                type => 'any',
            },
        code    => sub {
        my $self = shift;
        my @params = @_;
        # ... your method's code here ...
        return HTTP_OK; # HTTP RC
    });
Registers new method and returns operation status
B<NOTE!> This is non class method!
=over 4
=item attrs
Sets attributes of the method as hashref
Default: {}
In the method's code or response method, you can get the attribute values using the $self->info("attrs") method
=item code
Sets callback function
Default: sub { return HTTP::Status::HTTP_OK }
This callback function MUST return HTTP status code
See L<HTTP::Status>
=item deep, depth
Enables deeply scanning of path for method lookup. If this param is set to true then the
mechanism of the deeply lookuping will be enabled. For example:
For registered path /foo with enabled deep lookuping will be matched any another
incoming path that begins from /foo prefix: /foo, /foo/bar, /foo/bar/baz and etc.
Default: 0
=item description
Sets the description of method
Default: none
=item name
Sets the name of method
Default: default
=item method
Sets the HTTP method for trapping. Supported: GET, POST, PUT, DELETE.
Default: GET
=item path
Sets the URL's path for trapping
Default: /
=item requires
Array-ref structure that contains list of groups/users or any data for authorization
Default: []
=item returns
Hash-ref structure that contains schema
Default: {}
See L<JSON::Schema>, L<JSON::Validator>, L<http://json-schema.org/>
=back
=head2 middleware
The middleware method. Runs before every Your registered methods.
You can override this method in Your class.
This method MUST returns HTTP status code.
If code is a Successful status code (2xx) then Your registered method will called
For examle:
    sub response {
            my $self = shift;
            my @params = @_;
            # . . .
            return HTTP::Status::HTTP_OK
    }
=head2 response
The method for response prepare.
You can override this method in Your class.
But note! This method MUST returns serialized or plain content for output
For examle:
    sub response {
        my $self = shift;
        my @params = @_;
        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";
        # . . .
        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);
    }
=head2 again
Internal use only!
See L<CTK::App/again>
=head1 EXAMPLES
See all examples on METACPAN website L<https://metacpan.org/release/WWW-MLite>
=head1 HISTORY
See C<Changes> file
=head1 TO DO
See C<TODO> file
=head1 BUGS
* none noted
Please report any bugs to https://rt.cpan.org/.
=head1 SEE ALSO
L<CTK>, L<HTTP::Message>
=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
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See C<LICENSE> file and L<https://dev.perl.org/licenses/>
=cut
use vars qw/ $VERSION /;
$VERSION = '2.01';
use base qw/ CTK /;
$CTK::PLUGIN_ALIAS_MAP{log} = "WWW::MLite::Log";
use Storable qw/dclone/; # for dclone
use HTTP::Status qw/ :is /;
use HTTP::Message;
use HTTP::Headers;
use HTTP::Response;
use HTTP::Date;
use CTK::ConfGenUtil;
use CTK::TFVals qw/ :ALL /;
use constant {
        APP_PLUGINS => [qw/
                config log
            /],
        METHODS => {
                GET     => 1,
                POST    => 1,
                PUT     => 1,
                DELETE  => 1,
                PATCH   => 1,
            },
        EOL                 => "\015\012",
        KEY_MASK            => "%s#%s", # METHOD, PATH
        REG_KEY_MASK        => "%s#%s#%d", # CLASS, SERVER_NAME, SERVER_PORT
        DEFAULT_METHOD      => "GET",
        DEFAULT_NAME        => "default",
        DEFAULT_PATH        => "/", # Root
        DEFAULT_SERVER_NAME => "localhost",
        DEFAULT_SERVER_PORT => 80,
        DEFAULT_CONTENT_TYPE=> "text/plain",
    };
my %method_registry;
sub again {
    my $self = shift;
    my $args = $self->origin;
    my $status = $self->load_plugins(@{(APP_PLUGINS)});
    $self->{status} = 0 unless $status;
    my $config = $self->configobj;
    # Autoloading logger (data from config)
    my $log_on = $config->get("logenable") || $config->get("logenabled") || 0;
    if ($self->logmode && $log_on) {
        my $logopts = $args->{logopts} || {};
        my $logfile = defined($args->{logfile}) ? $self->logfile : $config->get("logfile"); # From args or config
        $logopts->{facility} = $args->{logfacility} if defined($args->{logfacility}); # From args only!
        if ($args->{logfd}) {
            $logopts->{fd} = $args->{logfd};
        } else {
            $logopts->{file} = $logfile if defined($logfile) && length($logfile);
        }
        $logopts->{ident} = defined($args->{ident})
            ? $args->{ident}
            : ($config->get("logident") // $self->project); # From args or config
        $logopts->{level} = defined($args->{loglevel})
            ? $args->{loglevel}
            : ($config->get("loglevel")); # From args or config
        $self->logger_init(%$logopts) or do {
            $self->error("Can't initialize logger");
            $self->{status} = 0;
        };
    }
    # Set methods
    my $registry_key = sprintf(REG_KEY_MASK,
        ref($self),
        $ENV{SERVER_NAME} || DEFAULT_SERVER_NAME,
        $ENV{SERVER_PORT} || DEFAULT_SERVER_PORT,
    );
    $self->{methods} = exists($method_registry{$registry_key}) ? $method_registry{$registry_key} : {},
    # Set name, info, code, head, data
    $self->{name} = undef; # Method name
    $self->{info} = undef; # Method info (without code)
    $self->{code} = undef; # Response code (RC)
    $self->{message} = undef; # Response message
    $self->{head} = undef; # Response headers
    $self->{data} = undef; # Response data
    $self->{request_method} = undef; # Request method
    $self->{request_uri} = undef; # Request uri
    return $self;
}
sub register_method {
    my $class = shift; # Caller's class
    croak("Can't use reference in class name context") if ref($class);
    my %info = @_;
    my $registry_key = sprintf(REG_KEY_MASK,
        $class,
        $ENV{SERVER_NAME} || DEFAULT_SERVER_NAME,
        $ENV{SERVER_PORT} || DEFAULT_SERVER_PORT,
    );
    $method_registry{$registry_key} = {} unless exists($method_registry{$registry_key});
    my $methods = $method_registry{$registry_key};
    # Method & Path
    my $meth = $info{method} || DEFAULT_METHOD;
    $meth = DEFAULT_METHOD unless grep {$_ eq $meth} keys %{(METHODS())};
    my $path = $info{path} // "";
    $path =~ s/\/+$//;
    $path = DEFAULT_PATH unless length($path);
    # Meta
    my $name = $info{name} || DEFAULT_NAME;
    my $code = $info{code} || sub {return HTTP::Status::HTTP_OK};
    my $attrs = $info{attrs} && is_hash($info{attrs}) ? $info{attrs} : {};
    my $returns = $info{returns} && is_hash($info{returns}) ? $info{returns} : {};
    my $description = $info{description} || "";
    my $deep = $info{deep} || $info{depth} || 0;
    my $requires = array($info{requires} || []);
    # Key
    my $key = sprintf(KEY_MASK, $meth, $path);
    if ($methods->{$key}) {
        my $tname = $methods->{$key}{name} || DEFAULT_NAME;
        return 0 if $tname ne $name;
    }
    $methods->{$key} = {
            method  => $meth,
            path    => $path,
            name    => $name,
            code    => $code,
            deep    => $deep,
            requires=> $requires,
            attrs   => $attrs,
            returns => $returns,
            description => $description,
        };
    return 1;
}
sub check_http_method {
    my $self = shift;
    my $meth = shift;
    return 0 unless $meth;
    return 1 if $meth eq 'HEAD';
    my $meths = METHODS;
    return $meths->{$meth} ? 1 : 0;
}
sub name {
    my $self = shift;
    return $self->{name} || DEFAULT_NAME;
}
sub info {
    my $self = shift;
    my $name = shift;
    my $meta = dclone($self->{info} || {name => $self->name});
    return $meta unless defined($name);
    return undef unless defined $meta->{$name};
    return $meta->{$name};
}
sub code {
    my $self = shift;
    my $value = shift;
    return fv2zero($self->{code}) unless defined($value);
    $self->{code} = $value || HTTP::Status::HTTP_OK;
    return $self->{code};
}
sub message {
    my $self = shift;
    my $value = shift;
    return $self->{message} unless defined($value);
    $self->{message} = $value || HTTP::Status::status_message(HTTP::Status::HTTP_OK);
    return $self->{message};
}
sub head {
    my $self = shift;
    my $struct = shift;
    return $self->{head} unless defined($struct);
    $self->{head} = $struct;
    return $struct;
}
sub data {
    my $self = shift;
    my $struct = shift;
    return $self->{data} unless defined($struct);
    $self->{data} = $struct;
    return $struct;
}
sub lookup_method {
    my $self = shift;
    my ($imeth, $ipath) = @_;
    # Method
    my $meth = uc($imeth || DEFAULT_METHOD);
    $meth = "GET" if $meth eq 'HEAD';
    unless ($self->check_http_method($meth)) {
        $self->error(sprintf("The HTTP %s method not allowed", $meth));
        return undef;
    }
    # Path
    my $path = $ipath || DEFAULT_PATH;
    $path =~ s/[?\#](.*)$//;
    $path =~ s/\/+$//;
    $path = DEFAULT_PATH unless length($path);
    # Get method
    my $name;
    my $key = sprintf(KEY_MASK, $meth, $path);
    my $methods = $self->{methods};
    # ...by key
    return $methods->{$key} if $methods->{$key}
        && $methods->{$key}{name}
        && $methods->{$key}{code};
    # ...by path
    foreach my $p (_scan_backward($path)) {
        my $ikey = sprintf(KEY_MASK, $meth, $p);
        return $methods->{$ikey} if $methods->{$ikey}
            && $methods->{$ikey}{deep}
            && $methods->{$ikey}{name}
            && $methods->{$ikey}{code};
    }
    $self->error(sprintf("Method not found (%s %s)", $meth, $path));
    return undef;
}
sub call_method {
    my $self = shift;
    my $meth = shift;
    my $path = shift;
    my @params = @_;
    $self->cleanup;
    $self->{request_method} = $meth;
    $self->{request_uri} = $path;
    my $method = $self->lookup_method($meth, $path) or return;
    unless(ref($method) eq 'HASH') {
        $self->error("Incorrect method structure");
        return;
    }
    # Get info
    my %info;
    my $func;
    foreach my $k (keys %$method) {
        next unless defined $k;
        if ($k eq 'code') {
            $func = $method->{code};
            next;
        } elsif ($k eq 'name') {
            $self->{name} = $method->{name};
        }
        $info{$k} = $method->{$k};
    }
    $self->{info} = dclone(\%info);
    # Call middleware method
    my $rc = $self->middleware(@params);
    # Call method
    if ($rc && !is_success($rc)) {
        # Skip!
    } elsif (ref($func) eq 'CODE') {
        $rc = &$func($self, @params);
    } else {
        $self->message(sprintf("The code of method %s not found!", $self->name));
        $rc = HTTP::Status::HTTP_NOT_IMPLEMENTED;
    }
    $self->{code} = $rc;
    # Call response method
    unless (HTTP::Status::status_message($rc)) {
        $self->message(sprintf("Method %s returns incorrect HTTP status code!", $self->name));
        $self->{code} = HTTP::Status::HTTP_INTERNAL_SERVER_ERROR;
    }
    return $self->response(@params);
}
sub call { goto &call_method }
sub cleanup {
    my $self = shift;
    $self->error(""); # Flush error
    $self->{name} = undef; # Method name
    $self->{info} = undef; # Method info (without code)
    $self->{code} = undef; # Response code (RC)
    $self->{message} = undef; # Response message
    $self->{head} = undef; # Response headers
    $self->{data} = undef; # Response data
    $self->{request_method} = undef; # Request method
    $self->{request_uri} = undef; # Request uri
    return 1;
}
sub middleware {
    my $self = shift;
    return HTTP::Status::HTTP_OK;
}
sub response {
    my $self = shift;
    my $rc = $self->code;
    my $head = $self->head;
    my $data = $self->data;
    my $msg = $self->message || HTTP::Status::status_message($rc) || "Unknown code";
    # Content
    my $dct = DEFAULT_CONTENT_TYPE;
    my $content = $data // "";
    $content = "" if $rc =~ /^(1\d\d|[23]04)$/; # make sure content we have no content
    if (utf8::is_utf8($content)) {
        utf8::encode($content);
        $dct .= "; charset=utf-8";
    }
    my $cl = length($content);
    $cl += length("\n") if $self->origin->{nph}; # Hack for HTTP::Message::as_string (eol char)
    # Headers
    my $h = HTTP::Headers->new(Status => sprintf("%s %s", $rc, $msg));
    if (is_void($head)) { # No data!
        $h->header('Server' => sprintf("%s/%s", __PACKAGE__, $VERSION));
        $h->header('Connection' => 'close');
        $h->header('Date' => HTTP::Date::time2str(time()));
        $h->header('Content-Type' => $dct);
    } elsif (is_hash($head)) { # Data!
        $h->header(%$head);
    }
    $h->header('Content-Length' => $cl) if $cl && !$h->header('Content-Length');
    # Response
    my $ishead = $self->{request_method} && $self->{request_method} eq 'HEAD' ? 1 : 0;
    my $r = HTTP::Response->new($rc, $msg, $h, ($cl && !$ishead ? $content : ""));
    # Done!
    return $self->origin->{nph}
        ? $r->as_string
        : join(EOL, $r->{'_headers'}->as_string(EOL), ($cl && !$ishead ? $content : ""));
}
sub _scan_backward { # Returns for /foo/bar/baz array: /foo/bar/baz, /foo/bar, /foo, /
    my $p = shift // '';
    my @out = ($p) if length($p) && $p ne '/';
    while ($p =~ s/\/[^\/]+$//) {
        push @out, $p if length($p)
    }
    push @out, '/';
    return @out;
}
1;
__END__