File Coverage

blib/lib/Dancer2/Plugin/WebService.pm

Criterion	Covered	Total	%
statement	45	504	8.9
branch	0	278	0.0
condition	0	73	0.0
subroutine	15	31	48.3
pod	6	7	85.7
total	66	893	7.3

# ABSTRACT: Rest APIs with login, persistent data, multiple in/out formats, IP security, role based access
# Multiple input/output formats : json , xml , yaml, perl , human
#
# George Bouras , [e-mail]
# Joan Ntzougani, ✞

package Dancer2::Plugin::WebService;
our $VERSION = '4.8.8';
if ( $^O =~/(?i)MSWin/ ) { CORE::warn "\nOperating system is not supported\n"; CORE::exit 1 }

use strict;
use warnings;
use Encode;
use Dancer2::Plugin;
use Storable;
use Data::Dumper;     $Data::Dumper::Sortkeys=0; $Data::Dumper::Indent=1; $Data::Dumper::Terse=1; $Data::Dumper::Deepcopy=1; $Data::Dumper::Purity=1; $Data::Dumper::Useperl=0; $Data::Dumper::Trailingcomma=0;
use XML::Hash::XS;    my $XML  = XML::Hash::XS->new(           utf8=>1,        indent=>0, canonical=>0, encoding=>'utf-8', root=>'root', xml_decl=>0);
use Cpanel::JSON::XS; my $JSON = Cpanel::JSON::XS->new; $JSON->utf8(1); $JSON->indent(0); $JSON->canonical(0); $JSON->pretty(0); $JSON->max_size(0); $JSON->space_before(0); $JSON->space_after(1); $JSON->relaxed(0); $JSON->allow_tags(1); $JSON->allow_unknown(0); $JSON->shrink(0); $JSON->allow_nonref(0); $JSON->allow_blessed(0); $JSON->convert_blessed(0); $JSON->max_depth(1024);
use YAML::XS;         my $YAML = YAML::XS->new(                utf8=>0,        indent=>2, header=>1, footer=>0, width=>2048, anchor_prefix=>'');


my %Formats = (json=>'application/json', xml=>'application/xml', yaml=>'application/yaml', perl=>'text/plain', human=>'text/plain');
my $fmt_rgx = eval 'qr/^('. join('|', sort keys %Formats) .')$/';
my $dir;
my $tmp;
my %Handler;
my %TokenDB;
my @keys;

has token           => (is=>'rw', lazy=>1, default    => undef);
has error           => (is=>'rw', lazy=>1, default    => 0);
has sort            => (is=>'rw', lazy=>1, default    => 0);
has pretty          => (is=>'rw', lazy=>1, default    => 1);
has route_name      => (is=>'rw', lazy=>1, default    => '');
has ClientIP        => (is=>'rw', lazy=>1, default    => '');
has reply_text      => (is=>'rw', lazy=>1, default    => '');
has auth_method     => (is=>'rw', lazy=>1, default    => '');
has auth_command    => (is=>'rw', lazy=>1, default    => '');
has data            => (is=>'rw', lazy=>1, default    => ''); # user posted data
has auth_config     => (is=>'rw', lazy=>1, default    => sub{ {} });
has Format          => (is=>'rw', lazy=>1, default    => sub{ {from => undef, to => undef} });
has Session_timeout => (is=>'ro', lazy=>0, from_config=> 'Session idle timeout',default=> sub{ 3600 }, isa => sub {unless ( $_[0]=~/^\d+$/ ) {warn "Session idle timeout \"$_[0]\" It is not a number\n"; exit 1}} );
has rules           => (is=>'ro', lazy=>0, from_config=> 'Allowed hosts',       default=> sub{ ['127.*', '192.168.*', '172.16.*'] });
has rules_compiled  => (is=>'ro', lazy=>0, default    => sub {my $array = [@{$_[0]->rules}]; for (@{$array}) { s/([^?*]+)/\Q$1\E/g; s|\?|.|g; s|\*+|.*?|g; $_ = qr/^$_$/i } $array});
has dir_session     => (is=>'ro', lazy=>0, default    => sub {my $D = exists $_[0]->config->{'Session directory'} ? $_[0]->config->{'Session directory'}."/$_[0]->{app}->{name}" : "$_[0]->{app}->{config}->{appdir}/session"; $D=~s|/+|/|g; my @MD = split /(?:\\|\/)+/, $D; my $i; for ($i=$#MD; $i>=0; $i--) { last if -d join '/', @MD[0..$i] } for (my $j=$i+1; $j<=$#MD; $j++) { unless (mkdir join '/', @MD[0 .. $j]) {warn "Could not create the session directory \"$D\" because $!\n"; exit 1} } $D} );
has OS              => (is=>'ro', lazy=>0, default    => sub {my $D = undef; foreach (qw[/usr/bin /bin /usr/sbin /sbin]) {if (-f "$_/uname") {$D="$_/uname"; last}; unless (defined $D) {warn "Could not found utility uname\n"; exit 1} } sub{-f $_[0] ? sub{open __F, $_[0]; $_=readline __F; close __F; ($_) = $_=~ /\A(\S+\s+\S+\s+\S+).*/ ; $_}->($_[0])  : sub { $_=qx[$D -sr] ; chomp ; $_ }->() }->('/proc/version') });
has rm              => (is=>'ro', lazy=>0, default    => sub {foreach (qw[/usr/bin /bin /usr/sbin /sbin]) {return "$_/rm" if -f "$_/rm" && -x "$_/rm" } warn "Could not found utility rm\n"; exit 1});
has session_enable  => (is=>'ro', lazy=>0, default    => sub {exists $_[0]->config->{'Session enable'} ? $_[0]->config->{'Session enable'}=~/(?i)[y1t]/ ? 1:0 : 1});

# Recursive walker of complex and custon Data Structures
%Handler=(
SCALAR => sub { $Handler{WALKER}->(${$_[0]}, $_[1], @{$_[2]} )},
ARRAY  => sub { $Handler{WALKER}->($_, $_[1], @{$_[2]}) for @{$_[0]} },
HASH   => sub { $Handler{WALKER}->($_[0]->{$_}, $_[1], @{$_[2]}, $_) for sort keys %{$_[0]} },
''     => sub { $_[1]->($_[0], @{$_[2]}) },
WALKER => sub { my $data = shift; $Handler{ref $data}->($data, shift, \@_) }
);


sub BUILD
{
my $plg = shift;
my $app = $plg->app;

(my $module_dir =__FILE__) =~s|/[^/]+$||; # Module's directory
unless (-d $module_dir) { CORE::warn "Could not find the Dancer2::Plugin::WebService installation directory\n"; CORE::exit 1 }

# Built-in routes and their security
$plg->config->{Routes}->{logout}              = { Protected => 1, 'Built in' => 1, Groups=>[] }; # we should be logged in to logout
$plg->config->{Routes}->{login}               = { Protected => 0, 'Built in' => 1 };
$plg->config->{Routes}->{WebService}          = { Protected => 0, 'Built in' => 1 };
$plg->config->{Routes}->{'WebService/client'} = { Protected => 0, 'Built in' => 1 };
$plg->config->{Routes}->{'WebService/routes'} = { Protected => 0, 'Built in' => 1 };
$plg->config->{Routes}->{''}                  = { Protected => 2, 'Built in' => 1 };

# Default settings
$plg->config->{'Default format'}= 'json' if ((! exists $plg->config->{'Default format'}) || ($plg->config->{'Default format'} !~ $fmt_rgx));
$app->config->{content_type}    = $Formats{ $plg->config->{'Default format'} };
$app->config->{show_errors}   //= 0;
$app->config->{charset}       //= 'UTF-8';
$app->config->{encoding}      //= 'UTF-8';

  # Use the first active authentication method
  foreach my $method (@{$plg->config->{'Authentication methods'}}) {
  next unless ((exists $method->{Active}) && ($method->{Active}=~/(?i)[y1t]/));
  $plg->auth_method( $method->{Name} );

    # If the Authorization method is an external script
    if ($plg->auth_method ne 'INTERNAL') {
    unless (exists $method->{Command}) {warn "The active Authentication method \"".$plg->auth_method."\" does not know what to do\n"; exit 1}
    $method->{Command} =~s/^MODULE_INSTALL_DIR/$module_dir/;
    unless (-f $method->{Command}) {warn "Sorry, could not found the external authorization utility $method->{Command}\n"; exit 1}
    unless (-x $method->{Command}) {warn "Sorry, the external authorization utility $method->{Command} is not executable from user ". getpwuid($>) ."\n"; exit 1}

      if ((exists $method->{'Use sudo'}) && ($method->{'Use sudo'}=~/(?i)[y1t]/)) {
      my $sudo = undef;
      foreach (qw[/usr/bin /bin /usr/sbin /sbin]) { if ((-f "$_/sudo") && -x ("$_/sudo")) { $sudo="$_/sudo"; last } }
      unless (defined $sudo) {warn "Could not found sudo command\n"; exit 1}
      $plg->auth_command( "$sudo \Q$method->{Command}\E" )
      }
      else {
      $plg->auth_command( "\Q$method->{Command}\E" )
      }
    }

  delete @{$method}{'Name','Active','Command','Use sudo'};
  $method->{Arguments} //= [];
  $plg->auth_config($method);
  last
  }

delete $plg->config->{'Session enable'};
delete $plg->config->{'Authentication methods'};

  if (($plg->session_enable) && ($plg->auth_method eq '')) {
  warn "\nWhile the sessions are enabled there is not any active authorization method at your config.yml\n";
  CORE::exit 1
  }

  # Check if there are protected routes
  foreach (keys %{$plg->config->{Routes}}) {
  next if exists  $plg->config->{Routes}->{$_}->{'Built in'};
  $plg->config->{Routes}->{$_}->{'Built in'}=0;

    if ((exists $plg->config->{Routes}->{$_}->{Protected}) && ($plg->config->{Routes}->{$_}->{Protected}=~/(?i)[y1t]/)) {

    delete $plg->config->{Routes}->{$_}->{Protected};
           $plg->config->{Routes}->{$_}->{Protected}=1;

      if ($plg->auth_method eq '') {
      warn "\nWhile there is at least one protected route ( $_ ) there is not any active authorization method at your config.yaml\n";
      CORE::exit 1
      }
      else {

        if (exists $plg->config->{Routes}->{$_}->{Groups}) {
        $plg->config->{Routes}->{$_}->{Groups} = [ $plg->config->{Routes}->{$_}->{Groups} ] unless 'ARRAY' eq ref $plg->config->{Routes}->{$_}->{Groups}
        }
        else {
        $plg->config->{Routes}->{$_}->{Groups} = []
        }
      }
    }
    else {
    delete $plg->config->{Routes}->{$_}->{Protected};
           $plg->config->{Routes}->{$_}->{Protected}=0
    }
  }

print STDOUT "\n";
print STDOUT "Application name      : ", $plg->dsl->config->{appname}  ,"\n";
print STDOUT 'Start time            : ', scalar localtime $^T ,"\n";
print STDOUT 'Run as user           : ', (getpwuid($>))[0] ,"\n";
print STDOUT "Command               : $0\n";
print STDOUT "PID parent            : ", getppid() ,"\n";
print STDOUT "PID Main              : $$\n";
print STDOUT 'Authorization method  : ', ( $plg->auth_method ? $plg->auth_method :'UNDEFINED' ) ,"\n";
print STDOUT "Authorization scripts : $module_dir/\n";
print STDOUT 'Environment           : ', $plg->dsl->config->{environment} ,"\n";
print STDOUT 'Logging               : ', $plg->dsl->config->{log} ,"\n";
print STDOUT 'Session enable        : ', ( $plg->session_enable ? 'Yes' : 'No') ,"\n";
print STDOUT 'Session directory     : ', $plg->dir_session ,"\n";
print STDOUT 'Session idle timeout  : ', $plg->Session_timeout ," sec\n";
print STDOUT "Version application   : ", ( exists $plg->dsl->config->{appversion} ? $plg->dsl->config->{appversion} : '0.0.0' ) ,"\n";
print STDOUT "Version Perl          : $^V\n";
print STDOUT "Version Dancer2       : $Dancer2::VERSION\n";
print STDOUT "Version WebService    : $VERSION\n";
print STDOUT "Operating system      : ", $plg->OS ,"\n";

# Restore the valid sessions, and delete the expired ones
opendir DIR, $plg->dir_session or die "Could not list session directory $plg->{dir_session} because $!\n";

  foreach my $token (grep ! /^\.+$/, readdir DIR) {

    if ((-f "$plg->{dir_session}/$token/control/lastaccess") && (-f "$plg->{dir_session}/$token/control/username") && (-f "$plg->{dir_session}/$token/control/groups")) {
    my $lastaccess = ${ Storable::retrieve "$plg->{dir_session}/$token/control/lastaccess" };

      if (time - $lastaccess > $plg->Session_timeout) {
      print STDOUT "Delete expired session: $token\n";
      system $plg->rm, '-rf', "$plg->{dir_session}/$token"
      }
      else {
        $TokenDB{$token}->{data} = {};
      @{$TokenDB{$token}->{control}}{qw/lastaccess username groups/} = ($lastaccess, ${Storable::retrieve "$plg->{dir_session}/$token/control/username"}, ${Storable::retrieve "$plg->{dir_session}/$token/control/groups"});

      opendir __TOKEN, "$plg->{dir_session}/$token/data" or die "Could not read session directory $plg->{dir_session}/$token/data because $!\n";

        foreach my $record (grep ! /^\.{1,2}$/, readdir __TOKEN) {
        next unless -f "$plg->{dir_session}/$token/data/$record";
        $record = Encode::decode('utf8', $record);
        $TokenDB{$token}->{data}->{$record} = Storable::retrieve "$plg->{dir_session}/$token/data/$record";
        $TokenDB{$token}->{data}->{$record} = ${ $TokenDB{$token}->{data}->{$record} } if 'SCALAR' eq ref $TokenDB{$token}->{data}->{$record}
        }

      close __TOKEN;
      print STDOUT "Restore session       : $token (". scalar(keys %{$TokenDB{$token}->{data}}) ." records)\n"
      }
    }
    else {
    print STDOUT "Delete corrupt session: $token\n";
    system $plg->rm,'-rf',"$plg->{dir_session}/$token"
    }
  }

closedir DIR;
print STDOUT "\n";


#print STDERR Dumper( $app ) ;exit;
#print STDERR Dumper( $plg->config->{Routes} ) ;exit;
#print STDERR Dumper( $plg->auth_config )      ;exit;
#print STDERR Dumper  \%TokenDB; exit;
#print STDERR "---------\n*".  $plg->dir_session  ."*\n---------\n";

## Catch hard errors
#  $app->add_hook(
#    Dancer2::Core::Hook->new( name => 'init_error', code => sub
#      {
#      print STDERR "\n---------\n";
#      print STDERR "debug  : ". Dumper( $_[0] );
#      print STDERR "\n---------\n";
#
#      $plg->error( 'Unknown route '. $plg->dsl->request->env->{REQUEST_URI} );
#      $_[0]->{content} = "{ \"error\" : \"". $plg->error . "\", \"reply\" : {} }"
#      }
#    )
#  );


# Hook, BEFORE the main app process the request

  $app->add_hook( Dancer2::Core::Hook->new( name => 'before', code => sub
  {
  $plg->error(0);
  $plg->token(undef);
  $plg->data({});
  $plg->sort(   exists $app->request->query_parameters->{sort}   ? $app->request->query_parameters->{sort}  =~/(?i)1|t|y/ ? 1:0:0);  # sort   default is 0
  $plg->pretty( exists $app->request->query_parameters->{pretty} ? $app->request->query_parameters->{pretty}=~/(?i)1|t|y/ ? 1:0:1);  # pretty default is 1
  $plg->ClientIP($app->request->env->{HTTP_X_REAL_IP} // $app->request->address // '127.0.0.1'); # Client IP address, even if running from a reverse proxy

    # format
    foreach (qw/from to/) {

      if (exists $app->request->query_parameters->{$_}) {

        if ( $app->request->query_parameters->{$_} =~ $fmt_rgx ) {
        $plg->Format->{$_} = $app->request->query_parameters->{$_}
        }
        else {

          if    ( $app->request->query_parameters->{$_} eq 'jsn' ) { $plg->Format->{$_} = 'json' }
          elsif ( $app->request->query_parameters->{$_} eq 'yml' ) { $plg->Format->{$_} = 'yaml' }
          elsif ( $app->request->query_parameters->{$_} eq 'txt' ) { $plg->Format->{$_} = 'human'}
          elsif ( $app->request->query_parameters->{$_} eq 'text') { $plg->Format->{$_} = 'human'}
          else  {
          $plg->Format->{to} = $plg->config->{'Default format'};
          $plg->error("Format parameter $_ ( ".$app->request->query_parameters->{$_}.' ) is not one of the : '. join(', ',keys %Formats));
          $plg->reply
          }
        }
      }
      else {
      $plg->Format->{$_} = $plg->config->{'Default format'}
      }
    }

  # Header Content-Type
  $app->request->header('Content-Type'=> $Formats{$plg->Format->{to}});


  # Check client IP address against the access rules
  $plg->error('Client IP address '.$plg->ClientIP.' is not allowed');
    for (my $i=0; $i<@{$plg->rules_compiled}; $i++) {
      if ( $plg->ClientIP =~ $plg->rules_compiled->[$i] ) {
      $plg->error(0);
      last
      }
    }
  $plg->reply if $plg->error;


  # route name
  if    ( $app->request->{route}->{regexp} =~/^\^[\/\\]+(.*?)[\/\\]+\(\?#token.*/ ) { $plg->route_name($1) }
  elsif ( $app->request->{route}->{regexp} =~/^\^[\/\\]+(.*?)\$/ )                  { $plg->route_name($1) }
  else  { $plg->error('Could not recognize the route'); $plg->reply }

    unless (exists $plg->config->{Routes}->{$1}) {
    $_=$1; s/\\//g;
    $plg->error("Unknown route $_ you have to add it at your config.yml under the Routes");
    $plg->reply
    }

    # The following code must pruduce the hash/array   $plg->data    from the posted text at Perl INTERNAL format
    if ($app->request->body) {

      eval {

        if    ('json'  eq $plg->Format->{from}) { $JSON->utf8(1); $plg->data( $JSON->decode(  $app->request->body ) ); $JSON->utf8(0) }
        elsif ('yaml'  eq $plg->Format->{from}) {                 $plg->data( $YAML->load(    $app->request->body ) ) }
        elsif ('xml'   eq $plg->Format->{from}) {                 $plg->data( $XML->xml2hash( $app->request->body ) ) }
        elsif ('perl'  eq $plg->Format->{from}) { $plg->data(                            eval $app->request->body   ) }
        elsif ('human' eq $plg->Format->{from}) { my $ref={};

          foreach (split /\v+/, $app->request->body) {
          my @array = split /\s*(?:=|\:|-->|->|\|)+\s*/, $_;
          next unless @array;

            if ($#array==0) {
            $ref->{data}->{default} = $array[0]
            }
            else {
            $ref->{data}->{$array[0]} = join ',', @array[1 .. $#array]
            }
          }

        $plg->data($ref)
        }
      };

			if ($@) {
			$@ =~s/[\s\v\h]+/ /g;
			$plg->error('Data parsing as '.$plg->Format->{from}." failed because $@");
      $plg->reply
      }

    # This should croak for wide characters because of the intentional Perl INTERNAL format
    #print STDERR "----------- in\n";  foreach (keys %{ $plg->data }) { print STDERR "$_ -> @{ $plg->data->{$_} }" }  print STDERR "\n-----------\n";                    # for json, yaml
    #print STDERR "----------- in\n"; my $h=$plg->data->{root}; foreach (keys %{ $plg->data->{root} }) { print STDERR "$_ , $h->{$_}\n" } print STDERR "-----------\n";  # for the xml
    }


    # Define the token if sent as a query parameter
    if (exists  $app->request->query_parameters->{token}) {
    $plg->token($app->request->query_parameters->{token});
    delete      $app->request->query_parameters->{token}
    }

    # Delete not needed control url parameters
    foreach (qw/from to sort pretty message/) {
    delete $app->request->query_parameters->{$_}
    }

    if ('HASH' eq ref $plg->data) {

      # Use data token as ... token !
      if ((exists $plg->data->{token}) && (! defined $plg->token))  {
      $plg->token($plg->data->{token});
      delete      $plg->data->{token}
      }

      # Use the url parameters as data
      foreach (keys %{$app->request->query_parameters}) {
      $plg->data->{$_} = $app->request->query_parameters->{$_}
      }
    }
    elsif ('ARRAY' eq ref $plg->data) {
    # probably we will should push the query parameters to data list or something else fancy
    # so far yada yada
    }
    else {
    $plg->error('Posted data are not keys or list'); $plg->reply
    }

  }));


# Hook ONLY for the protected routes, before the main app do anything
# halt if the session is expired, otherelse update the lastaccess

  $app->add_hook( Dancer2::Core::Hook->new(name=>'before', code=>sub{
  return unless (exists $plg->config->{Routes}->{$plg->route_name}) && ($plg->config->{Routes}->{$plg->route_name}->{Protected} == 1);

  if (! defined $plg->token )            { $plg->error("You must provide a token to use the protected route $plg->{route_name}"); $plg->reply }
  if (! exists $TokenDB{ $plg->token } ) { $plg->error('Invalid token'); $plg->reply }
  $dir = $plg->dir_session.'/'.$plg->token;

    if (time - $TokenDB{ $plg->token }->{control}->{lastaccess} > $plg->Session_timeout) {
    $plg->error('Session expired because its idle time '.(time - $TokenDB{ $plg->token }->{control}->{lastaccess}).' secs is more than the allowed '.$plg->Session_timeout.' secs');
    system $plg->rm,'-rf',$dir;
    delete $TokenDB{ $plg->token };
    $plg->data({});	# clear user data
    $plg->reply
    }
    else {
    # update the lastaccess
    $TokenDB{ $plg->token }->{control}->{lastaccess} = time;
    Storable::lock_store \$TokenDB{ $plg->token }->{control}->{lastaccess}, "$dir/control/lastaccess"
    }

	# Check if the user is member to all the Groups of the route
  $tmp=0;

    foreach (@{$plg->config->{Routes}->{$plg->route_name}->{Groups}}) {

      if (exists $TokenDB{ $plg->token }->{control}->{groups}->{$_} ) {
      $tmp=1;
      last
      }

      unless ($tmp) {
      $plg->error('Required route groups are '. join(',',@{$plg->config->{Routes}->{$plg->route_name}->{Groups}}) .' your groups are '. join(',', sort keys %{$TokenDB{ $plg->token }->{control}->{groups}}));
      $plg->reply
      }
    }

  }));


  # Built-in route /WebService list the routes
  $app->add_route(
  regexp => '/WebService',
  method => 'get',
  code   => sub {

      $plg->reply(
        {
        Application          => $app->{name},
        Server               => { bind => $app->request->env->{SERVER_NAME} , port => $app->request->env->{SERVER_PORT} , uptime => time - $^T },
        'Login idle timeout' => $plg->Session_timeout,
        'Auth method'        => ( $plg->auth_method ? $plg->auth_method :'UNDEFINED' ),
        Version              => {
          $app->{name}       => ( exists $plg->dsl->config->{appversion} ? $plg->dsl->config->{appversion} : '0.0.0' ),
          Dancer2            => $Dancer2::VERSION,
          Os                 => $plg->OS,
          Perl               => $],
          WebService         => $VERSION
          }
        }
      )
    }
  );

  # Built-in route /WebService/:what
  $app->add_route(
  regexp => '/WebService/:what?',
  method => 'get',
  code   => sub { $plg->error(0);

      if ( $app->request->param('what') =~/(?i)\Ar/ ) {

        $plg->reply(
          {
          'Built in'		=> {
            'Protected' => [ map { $_ }          grep   $plg->config->{Routes}->{$_}->{'Built in'} && $plg->config->{Routes}->{$_}->{Protected}==1, sort keys %{$plg->config->{Routes}} ],
            'Public'    => [ map { $_ }          grep   $plg->config->{Routes}->{$_}->{'Built in'} && $plg->config->{Routes}->{$_}->{Protected}==0, sort keys %{$plg->config->{Routes}} ]
            },
          $plg->dsl->config->{appname} => {
            'Protected' => [ map { s/\\//g; $_ } grep ! $plg->config->{Routes}->{$_}->{'Built in'} && $plg->config->{Routes}->{$_}->{Protected}==1, sort keys %{$plg->config->{Routes}} ],
            'Public'    => [ map { s/\\//g; $_ } grep ! $plg->config->{Routes}->{$_}->{'Built in'} && $plg->config->{Routes}->{$_}->{Protected}==0, sort keys %{$plg->config->{Routes}} ]
            }
          }
        )
      }
      elsif ( $app->request->param('what') =~/(?i)\Ac/ ) {

        $plg->reply(
          {
          Address           => $plg->ClientIP,
          Port              => $app->request->env->{REMOTE_PORT},
          Agent             => $app->request->agent,
          Protocol          => $app->request->protocol,
          'Is secure'       => $app->request->secure,
          'Http method'     => $app->request->method,
          'Header accept'   => $app->request->header('accept'),
          'Parameters url'  => join(' ', $app->request->params('query')),
          'Parameters route'=> join(' ', $app->request->params('route')),
          'Parameters body' => join(' ', $app->request->params('body'))
          }
        )
      }
      else {
      $plg->error('Not existing internal route /WebService/'.$app->request->param('what')); $plg->reply
      }
    }
  );

  # logout and delete the session
  $app->add_route(
  regexp => '/logout',
  method => $_,
  code   => sub {
    $plg->error(0);
    delete $TokenDB{ $plg->token };
    system $plg->rm,'-rf', $plg->dir_session.'/'.$plg->token if -d $plg->dir_session.'/'.$plg->token;
    $plg->data({});
    $plg->reply( { token => $plg->token } )
    }
  ) foreach 'get','post','put';


	# Authentication
	$app->add_route(
	regexp => '/login',
	method => $_,
	code   => sub {
  if ($plg->auth_method eq '') { $plg->error('There is not any enabled authentication method at the config.yml'); $plg->reply }

  # Check the input parameters
  foreach ('username','password') {unless (exists $plg->data->{$_}) { $plg->error("Missing mandatory key $_"); $plg->reply }}
  if ( $plg->data->{username} =~/^\s*$/ ) { $plg->error('username can not be blank'); $plg->reply }
  if ( $plg->data->{password} eq ''     ) { $plg->error('password can not be blank'); $plg->reply }

  my $app    = shift;
  my $groups = {};
  $plg->error('authorization error');

    # Internal
    if ($plg->auth_method eq 'INTERNAL') {

      if (exists $plg->auth_config->{Accounts}->{ $plg->data->{username} }) {
        if      ($plg->auth_config->{Accounts}->{ $plg->data->{username} } eq '')                {$plg->error(0)} # global password
        elsif   ($plg->auth_config->{Accounts}->{ $plg->data->{username} } eq $plg->data->{password}) {$plg->error(0)} # normal
      }

      if ($plg->error && exists $plg->auth_config->{Accounts}->{''}) {
        if    ($plg->auth_config->{Accounts}->{''} eq '')                {$plg->error(0)} # global user and global password
        elsif ($plg->auth_config->{Accounts}->{''} eq $plg->data->{password}) {$plg->error(0)} # global user and normal password
      }
    }

    # The external authorization scripts expect at least the two arguments
    #
    #	1) username as hex string (for avoiding shell attacks)
    #	2) password as hex string
    #
    # Script output must be the two lines
    #
    #	1) 0 for successful login , or the error message at fail
    #	2) All the groups that the user belongs

    else {
    my @output;
    my $command	= $plg->auth_command.' '.unpack('H*', $plg->data->{username}).' '.unpack('H*', $plg->data->{password});
    if (@{$plg->auth_config->{Arguments}}) { $command .=' '.join ' ', map { "\"$_\"" } @{$plg->auth_config->{Arguments}} }

    # Execute the external authorization utility and capture its 3 lines output at @output array
    open   SHELL, '-|', "$command 2> /dev/null" or die "Could run AuthScript \"$command\" because \"$?\"\n";
    while() {s/^\s*(.*?)\s*$/$1/; push @output,$_}
    close  SHELL;

    unless (2 == scalar @output) { $plg->error('Expected 2 lines output instead of '.scalar(@output).' at auth method '.$plg->auth_method ); $plg->reply }
    $plg->error($output[0]);
    map { $groups->{$_} = 1 } split /,/,$output[1]
    }

  $plg->reply if $plg->error;

  # Create the token and session dir
  open  URANDOM__, '<', '/dev/urandom' or die "\nCould not read device /dev/urandom\n";
  read  URANDOM__, my $i, 12;
  close URANDOM__;
  $tmp = time.'-'.unpack 'h*',$i;
  $i=0;
  while ( -e $plg->dir_session .'/'. $tmp .'-'. $i++ ) {}
  $tmp .= '-'. (--$i);

    foreach ("$plg->{dir_session}/$tmp", "$plg->{dir_session}/$tmp/control", "$plg->{dir_session}/$tmp/data") {
    unless (mkdir $_) { $plg->error("Could not create session directory $_ because $!"); $plg->reply }
    }

    $TokenDB{$tmp}->{data} = {};
  @{$TokenDB{$tmp}->{control}}{qw/lastaccess groups username/} = (time,$groups,$plg->data->{username});

    while (my ($k,$v) = each %{ $TokenDB{$tmp}->{control} }) {

      unless ( Storable::lock_store \$v, "$plg->{dir_session}/$tmp/control/$k" ) {
      $plg->error("Could not store session data $_[$i] because $!"); $plg->reply
      }
    }

  $plg->reply( { token=>$tmp, groups=>[sort keys %{$groups}] } )
  }) foreach 'post', 'put'
}



#	Accepts a Perl data structure, and under the key "reply" returns a string formated as : json, xml, yaml, perl or human
# It also returns any error defined from the Error(...)
# A typical response is
#
# {
# "reply" : { "k1" : "B", "k2" : "v2" },
# "error" : "oh no"
# }
#
#	reply
#	reply(   'hello world'        )
#	reply( [ 'a', 'b' , 'c' ]     )
#	reply( { k1=>'v1', k1=>'v1' } )
#	reply(   'a', 'b' , 'c'       )
#	reply(  \&SomeFunction        )

sub reply :PluginKeyword
{
my $plg=shift;

  if ($#_ == -1) {
  $plg->__STRUCTURE_TO_STRING( { error => $plg->error, reply => {} } ) # if no argument return only the error
  }
  elsif ($#_ == 0) {
    if (ref $_[0]) {
      if    ('HASH'   eq ref $_[0]) { $plg->__STRUCTURE_TO_STRING( { error => $plg->error, reply => $_[0]    } ) }
      elsif ('ARRAY'  eq ref $_[0]) { $plg->__STRUCTURE_TO_STRING( { error => $plg->error, reply => $_[0]    } ) }
      elsif ('SCALAR' eq ref $_[0]) { $plg->__STRUCTURE_TO_STRING( { error => $plg->error, reply => ${$_[0]} } ) }
      elsif ('GLOB'   eq ref $_[0]) { $plg->__STRUCTURE_TO_STRING( { error => $plg->error, reply => 'GLOB'   } ) }
      elsif ('CODE'   eq ref $_[0]) {
      @keys = &{$_[0]}();

        if (0 == $#keys) {
          if (ref $keys[0]) {
            if    ('HASH'   eq ref $keys[0]) { $plg->__STRUCTURE_TO_STRING( { error => $plg->error, reply => $keys[0]    } ) }
            elsif ('ARRAY'  eq ref $keys[0]) { $plg->__STRUCTURE_TO_STRING( { error => $plg->error, reply => $keys[0]    } ) }
            elsif ('SCALAR' eq ref $keys[0]) { $plg->__STRUCTURE_TO_STRING( { error => $plg->error, reply => ${$keys[0]} } ) }
            elsif ('GLOB'   eq ref $keys[0]) { $plg->__STRUCTURE_TO_STRING( { error => $plg->error, reply => 'GLOB'      } ) }
            elsif ('CODE'   eq ref $keys[0]) { $plg->__STRUCTURE_TO_STRING( { error => $plg->error, reply => 'CODE'      } ) }
            else                             { $plg->__STRUCTURE_TO_STRING( { error => $plg->error, reply => ${$keys[0]} } ) }
          }
          else {
          $plg->__STRUCTURE_TO_STRING( { error => $plg->error, reply => $keys[0] } )
          }
        }
        else {
        $plg->__STRUCTURE_TO_STRING( { error => $plg->error, reply => [ @keys ] } )
        }
      }
    }
    else {
    $plg->__STRUCTURE_TO_STRING( { error=> $plg->error, reply => $_[0] } )
    }
  }
  else {
  $plg->__STRUCTURE_TO_STRING( { error => $plg->error, reply => [ @_ ] } )
  }

$plg->dsl->halt( $plg->reply_text )
}



#	Convert a hash, array, scalar reference to sting as $plg->reply_text
# The $_[0] is array/hash encoded to INTERNAL perl format
#	$plg->__STRUCTURE_TO_STRING( Hash ref|Array ref|... )

sub __STRUCTURE_TO_STRING
{
my $plg=shift;
$plg->reply_text('');

	eval {

		if ($plg->Format->{to} eq 'json') {
		$JSON->canonical($plg->sort);

			if ($plg->pretty) {
      $JSON->pretty(1); $JSON->space_after(1) } else {
			$JSON->pretty(0); $JSON->space_after(0)
			}

    #print STDERR "----------- out\n";  foreach (keys %{$_[0]->{reply}}) { print STDERR "$_ -> @{$_[0]->{reply}->{$_}} \n" }  print STDERR "-----------\n";

      if (($plg->Format->{from} eq 'human') || ($plg->Format->{from} eq 'perl')) {
      $JSON->utf8(0);
      $plg->{reply_text} = Encode::decode('utf8', $JSON->encode($_[0]) );
      $JSON->utf8(1)
      }
      else {
      $JSON->utf8(0);
      $plg->{reply_text} = $JSON->encode($_[0]);
      $JSON->utf8(1)
      }
		}


		elsif ($plg->Format->{to} eq 'xml') {
    #print STDERR "-----------  out\n";  print STDERR $plg->{reply_text} = $XML->hash2xml($_[0], utf8=>0, canonical=> $plg->sort, indent=> ($plg->pretty ? 2:0) );  ;print STDERR "\n-----------\n";
    $plg->{reply_text} = $XML->hash2xml($_[0], canonical=> $plg->sort, indent=> ($plg->pretty ? 2:0) )  # $XML->hash2xml($_[0], utf8=>1, canonical=> $plg->sort, indent=> ($plg->pretty ? 2:0) )
		}

		elsif ($plg->Format->{to} eq 'yaml') {
    #print STDERR "-----------  out\n";  print STDERR $YAML->dump($_[0])  ;print STDERR "\n-----------\n";
    $plg->{reply_text} = $YAML->dump($_[0]);  # It needs INTERNAL format
		}

		elsif ($plg->Format->{to} eq 'human') {

      if (($plg->Format->{from} eq 'human') || ($plg->Format->{from} eq 'perl')) {
      $Handler{WALKER}->($_[0], sub {my $val=shift; $val =~s/^\s*(.*?)\s*$/$1/; $plg->{reply_text} .= Encode::decode('utf8',  join('.', @_) ." = $val\n" ) } )
      }
      else {
      $Handler{WALKER}->($_[0], sub {my $val=shift; $val =~s/^\s*(.*?)\s*$/$1/; $plg->{reply_text} .= join('.', @_) ." = $val\n"})
      }
		}

		elsif ($plg->Format->{to} eq 'perl') {
		$Data::Dumper::Indent=$plg->pretty;
		$Data::Dumper::Sortkeys=$plg->sort;
    # print STDERR "-----------\n";  foreach (keys %{$_[0]->{reply}}) { print STDERR "out : $_ -> @{$_[0]->{reply}->{$_}} \n" }  print STDERR "\n-----------\n";

      if (($plg->Format->{from} eq 'human') || ($plg->Format->{from} eq 'perl')) {
      $plg->{reply_text} = Encode::decode('utf8', Data::Dumper::Dumper $_[0])
      }
      else {
      $plg->{reply_text} = Data::Dumper::Dumper $_[0]
      }
		}
	};

	if ($@) {
	$@=~s/[\v\h]+/ /g;
	$plg->dsl->halt("{\"error\" : \"FATAL, Internal structure to string convertion failed\"}")
	}
}



#  Retruns a  hash  referense if the data are posted as hash
#  Retruns an array referense if the data are posted as list
#
#	 UserData();              # all               posted data of $plg->data
#	 UserData( 'k1', 'k2' );  # only the selected posted data of $plg->data
#
sub UserData :PluginKeyword
{
my $plg=shift;

  if (@_) {

    if ('HASH' eq ref $plg->data) {
    $tmp={}; @{$tmp}{@_}=();

      foreach (keys %{$plg->data}) {
      delete $plg->data->{$_} unless exists $tmp->{$_}
      }
    }

    elsif ('ARRAY' eq ref $plg->data) {
    $tmp={}; @{$tmp}{@_}=();
    $plg->data( [ grep exists $tmp->{$_}, @{$plg->data} ] ) # Redefine the $plg->data from any valid values of the $plg->data
    }

    elsif ('SCALAR' eq ref $plg->data) { foreach (@_) { $plg->data($_) if $_ eq ${$plg->data} } }
    else                               { foreach (@_) { $plg->data($_) if $_ eq   $plg->data  } }
  }

$plg->data
}


#   Set session data
#   Session data are not volatile like the posted by user
#   They are persistent between requests until the user logout or its session get expired
#   Returns a list of the stored keys
#
#   SessionSet(  k1 => 'v1', k2 => 'v2'  );
#   SessionSet( {k1 => 'v1', k2 => 'v2'} );

sub SessionSet :PluginKeyword
{
my $plg=shift;

  if ($plg->session_enable) {

    if (defined $plg->token) {

      if ( ! exists $TokenDB{ $plg->token } ) {
      $plg->error('Invalid token');
      $plg->reply
      }
    }
    else {
    $plg->error('You need a token via login route for saving session data');
    $plg->reply
    }
  }
  else {
  $plg->error('Sessions are disabled at application config.yml');
  $plg->reply
  }

@_ = %{$_[0]} if (1 == @_) && ('HASH' eq ref $_[0]);
@keys=();

  # $_[$k] is the key
  # $_[$v] is the value
  for (my ($k,$v)=(0,1); $k<$#_-(@_ % 2); $k+=2,$v+=2) {
  next if 'token' eq $_[$k];
  push @keys, $_[$k];
  $TokenDB{$plg->token}->{data}->{$_[$k]} = $_[$v];

    unless ( Storable::lock_store ref $_[$v] ? $_[$v] : \$_[$v],  "$plg->{dir_session}/". $plg->token  ."/data/$_[$k]" ) {
    $plg->error("Could not store session key $_[$k] because $!");
    $plg->reply
    }
	}

@keys
}


#	Retrieves session keys
#
#	my %data = SessionGet();                 # hash of all keys
#	my %data = SessionGet('k1', 'k2', ...);  # hash of the selected keys

sub SessionGet :PluginKeyword
{
my $plg	= shift;

  if ($plg->session_enable) {

    if (defined $plg->token) {

      if (! exists $TokenDB{$plg->token}) {
      $plg->error('Invalid token');
      $plg->reply
      }
    }
    else {
    $plg->error('You need a token via login route for reading session data');
    $plg->reply
    }
  }
  else {
  $plg->error('Sessions are disabled at application config.yml');
  $plg->reply
  }

	if (0 == scalar @_) {
  # all records
	map { $_ , $TokenDB{$plg->token}->{data}->{$_}} keys %{$TokenDB{$plg->token}->{data}}
	}
	elsif ((1 == scalar @_)) {
  # one record

		if ('ARRAY' eq ref $_[0]) {
		# At new Perl versions hash slice  %{$TokenDB{ $plg->token }->{data}}{@{$_[0]}}
    map {exists $TokenDB{$plg->token}->{data}->{$_} ? ( $_ , $TokenDB{$plg->token}->{data}->{$_} ) : ()} @{$_[0]}
		}
		else {
         exists $TokenDB{$plg->token}->{data}->{$_[0]} ? ( $_[0] , $TokenDB{$plg->token}->{data}->{$_[0]} ) : ()
		}
	}
	else {
  # Some records, normal, not array reference
  map { ( $_ , $TokenDB{$plg->token}->{data}->{$_} ) }  grep exists $TokenDB{$plg->token}->{data}->{$_} , @_
	}
}


#	Delete session data
# Retun a list of the deleted keys
#
#		SessionDel()                  # delete all  records
#		SessionDel(   'k1', 'k2'   )  # delete some records
#   SessionDel( [ 'k1', 'k2' ] )  # delete some records

#
sub SessionDel :PluginKeyword
{
my $plg	= shift;

  if ($plg->session_enable) {

    if (defined $plg->token) {

      if ( ! exists $TokenDB{$plg->token} ) {
      $plg->error('Invalid token');
      $plg->reply
      }
    }
    else {
    $plg->error('You need a token via login route for deleting session data');
    $plg->reply
    }
  }
  else {
  $plg->error('Sessions are disabled at application config.yml');
  $plg->reply
  }

$dir = $plg->dir_session.'/'.$plg->token;
@keys=();

  if (@_) {
  @_ = @{$_[0]} if (1 == @_) && ('ARRAY' eq ref $_[0]);

    foreach (@_) {

      if (exists $TokenDB{$plg->token}->{data}->{$_}) {
      delete     $TokenDB{$plg->token}->{data}->{$_};
      push @keys, $_;
      unlink "$dir/data/$_" if -f "$dir/data/$_"
      }
    }
  }
  else {

		foreach (keys %{$TokenDB{$plg->token}->{data}}) {
    delete          $TokenDB{$plg->token}->{data}->{$_};
    push @keys, $_;
    unlink "$dir/data/$_" if -f "$dir/data/$_"
		}
  }

@keys
}


#	Set the error
# any['get','post','put'] => '/error1' => sub { Error('ok'); reply 'hello' };   #  { "error" : "ok" , ... }
# any['get','post','put'] => '/error2' => sub { Error('ok'); reply         };   #  { "error" : "ok", reply: {} }
# any['get','post','put'] => '/error2' => sub {              reply 'hello' };   #  { "error" : "Something went wrong", ...  }

sub Error :PluginKeyword { $_[0]->error( exists $_[1] ? $_[1] : 'Something went wrong' ) }

1;

=pod

=encoding UTF-8

=head1 NAME

Dancer2::Plugin::WebService - Rest APIs with login, persistent data, multiple in/out formats, IP security, role based access

=head1 VERSION

version 4.8.8

=head1 SYNOPSIS

  get '/my_keys' => sub { reply { 'k1'=>'v1' , 'k2'=>'v2' } };

  curl $url/my_keys

=head1 DESCRIPTION

Create REST APIs with login, logout, persistent session data, IP security, role based access.
Multiple input/output supported formats : json , xml , yaml, perl , human
Post your data and keys as url parameters or content body text

  curl -X GET  "$url/SomeRoute?k1=v1&k2=v2&k3=v3"
  curl -X POST  $url/SomeRoute -d '{ "k1":"v1", "k2":"v2", "k3":"v3" }'

=head1 NAME

Convert your functions to REST api with minimal effort

=head1 URL parameters to format the reply

You can use the  B, B, B, B  parameters to define the input/output format

=over 2

=item I , I

Define the input/output format.

You can define input/output formats independently.
B default is the B property B
Supported formats are

  json or jsn
  yaml or yml
  xml
  perl
  human or text or txt

  curl "$url/mirror?from=perl&to=xml" -d '{ "k1" => ["v1","v2","v3"] }'

=item I

If true the keys are returned sorted. The default is false because it is faster. Valid values are true, 1, yes, false, 0, no

=item I

If false, the data are returned as one line compacted. The default is true, for human readable output. Valid values are true, 1, yes, false, 0, no

=back

=head1 METHODS

Plugin methods available for your main Dancer2 code

=head2 UserData

Get all or some of the posted data
Retruns a hash referense if the data are posted as hash
Retruns an array referense if the data are posted as list

  UserData               Returns everything
  UserData('k1','k2')    Returns only the specific keys of the posted hash/list

  get '/SomePath' => sub { reply UserData };

=head2 reply

Your last route's statement. Accepts a Perl data structure, and return it as json, xml, yaml, perl or human under the key I

  reply(   'hello world'        )
  reply(  \'hello world'        )
  reply(   'a', 'b' , 'c'       )
  reply( [ 'a', 'b' , 'c' ]     )
  reply( { k1=>'v1', k2=>'v2' } )
  reply(   &SomeFunction        )
  reply(  \&SomeFunction        )

=head2 Error

Set the error. Normally at success B should be 0
It does not stop the route execution. You must place it before the reply()

  get '/SomePath' => sub { Error('oups') ; reply };
  get '/SomePath' => sub { Error('ok')   ; reply 'hello world' };

=head2 SessionSet

Store session persistent data, unlike the volatile common posted data. It is a protected method, I is required

They are persistent between requests until they deleted, the user logout or their session get expired.

You must pass your data as hash or hash reference.

Returns a list of the stored keys.

  any['get','post'] => '/session_save' => sub
  {
  @arr = SessionSet(   k1=>'v1' , k2=>'v2'   );
  @arr = SessionSet( { k3=>'v3' , k4=>'v4' } );
  reply { 'Your saved keys are' => \@arr }
  };

  curl $url/session_save?token=17398-5c8a71b -H "$H" -X POST -d '{"k1":"v1", "k2":"v2", ... }'

=head2 SessionGet

Read session persistent data. It is a protected method, I

Returns a hash

  any['post','put'] => '/session_read' => sub {
  my %hash1 = SessionGet(   'k1','k2'   );       # some records
  my %hash2 = SessionGet( [ 'k1','k2' ] );       # some records
  my %hash3 = SessionGet();                      # all  records
  reply { %hash3 }
  };

  curl $url/session_read?token=17398-5c8a71b

=head2 SessionDel

Deletes session persistent data. It is a protected method, I

Returns a list of the deleted keys

  SessionDel;                              delete all keys
  SessionDel(   'rec1', 'rec2', ...   );   delete selected keys
  SessionDel( [ 'rec1', 'rec2', ... ] );   delete selected keys

  any['delete'] => '/session_delete' => sub {
  my $arg = UserData();
  my @arr = SessionDel( $arg );
  reply { 'Deleted keys' => \@arr }
  };

  curl -X DELETE $url/session_delete?token=17398-5c8a71b -H "$H" -d '["k1","k2","k9"]'

  {
    "error" : 0,
    "reply" : {
        "Deleted keys" : [ "k1" , "k2" ]
    }
  }

=head1 Authentication and role based access control

The routes can be either B or B

=over 2

=item B

  routes that you must provide the I, as returned by the I route.
  Afer login, you can save, update, read, delete persistent session data

  The B route is using the the first active authentication method of the I

=item B

  routes that anyone can use without B , they do not support sessions / persistent data.

=back

=head1 Configuration file "I"

This file customize the I, I, I, I and I. The following is an example

  appname                 : TestService
  appversion              : 1.0.0
  environment             : development
  layout                  : main
  charset                 : UTF-8
  template                : template_toolkit
  engines                 : {template: {template_toolkit: {EVAL_PERL: 0, start_tag: '[%', end_tag: '%]' }}}
  plugins:
    WebService:
      Session enable      : true
      Session directory   : /var/lib/WebService
      Session idle timeout: 86400
      Default format      : json
      Allowed hosts       :
      - "127.*"
      - "172.20.20.*"
      - "????:????:????:6d00:20c:29ff:*:ffa3"
      - "10.*.?.*"
      - "*"

      Routes:
        text              : { Protected: false }
        mirror            : { Protected: false }
        Protected         : { Protected: true  }
        Protected_text_ref: { Protected: true  }
        list              : { Protected: false }
        list_ref          : { Protected: false }
        hash              : { Protected: false }
        code\/text        : { Protected: false }
        code\/list        : { Protected: false }
        code\/hash        : { Protected: false }
        code\/text_ref    : { Protected: false }
        code\/list_ref    : { Protected: false }
        keys_selected     : { Protected: false }
        git\/commit       : { Protected: true, Groups: [ git , ansibleremote ] }
        session_save      : { Protected: true, Groups: [] }
        session_read      : { Protected: true, Groups: [] }
        session_delete    : { Protected: true, Groups: [] }

      Authentication methods:

      - Name      : INTERNAL
        Active    : true
        Accounts  :
          user1   : s3cr3T+PA55sW0rD
          user2   :
             : S3cREt-4-aLl
        #   :

      - Name      : Linux native users
        Active    : false
        Command   : MODULE_INSTALL_DIR/AuthScripts/Linux_native_authentication.sh
        Arguments : [ ]
        Use sudo  : true

      - Name      : Basic Apache auth for simple users
        Active    : false
        Command   : MODULE_INSTALL_DIR/AuthScripts/HttpBasic.sh
        Arguments : [ "/etc/htpasswd" ]
        Use sudo  : false

=head1 Authentication methods

Authentication method can be INTERNAL or external executable Command.

At INTERNAL you define the usernames / passwords directly at the I . The  means any username or password,
so if you want to allow all users to login no matter the username or the password use

   :

This make sense if you just want to give anyone the ability for persistent data

The protected routes, at  config.yml  have   Protected:true and their required groups e.g.  Groups:[grp1,grp2 ...]

The user must be member to B defined groups

If the route's Groups list is empty or missing, then the groups membership is ignored

This way you can have user based access, because every user is allowed to access his assigned routes.

=head1 Authentication scripts

At production enviroments, probably you want to use external authenticators, accessed by plugable scripts e.g for the native "Linux native" authentication

  MODULE_INSTALL_DIR/AuthScripts/Linux_native_authentication.sh

It is easy to write your own scripts for LDAP, Active Directory, OAuth 2.0, Keycload, etc external authenticators.

If the script needs sudo, you must add the user running the application to sudoers e.g

  dendrodb ALL=(ALL:ALL) NOPASSWD: /usr/share/perl5/site_perl/Dancer2/Plugin/AuthScripts/some_auth_script.sh

Please read the file  AUTHENTICATION_SCRIPTS  for the details

=head1 IP access

You can control which clients are allowed to use your application at the file I

The rules are checked from up to bottom until there is a match. If no rule match then the client can not login. At rules your can use the wildcard characters * ?

  ...
  plugins:
    WebService:
      Allowed hosts:
      - 127.*
      - 10.*
      - 172.20.*
      - 32.??.34.4?
      - 4.?.?.??
      - ????:????:????:6d00:20c:29ff:*:ffa3
      - 192.168.0.153
      - "*"

=head1 Sessions

Upon successful login, the client is in session until logout or its session expired due to inactivity.

While in session you can access protected routes and save, read, delete session persistent data.

at the I You can change persistent data storage directory and session expiration

=over 2

=item B

  Be careful this directory must be writable from the user that is running the service
  To set the sessions directory

  plugins:
    WebService:
      Session directory : /var/lib/WebService

  or at your application

  setting('plugins')->{'WebService'}->{'Session directory'} = '/var/lib/WebService';

=item B

  Sessions are expiring after some seconds of inactivity. You can change the amount of seconds either at the I

  plugins:
    WebService:
      Session idle timeout : 3600

  or at your application

  setting('plugins')->{'WebService'}->{'Session idle timeout'} = 3600;

=back

=head1 Built in plugin routes

These are plugin built in routes

  WebService            version
  WebService/client     client propertis
  WebService/routes     list the built-in and application routes
  login                 login
  logout                logout

Usage examples

  export url=http://127.0.0.1:3000 H="Content-Type: application/json"
  alias curl="$(/usr/bin/which curl) --silent --user-agent Perl"

  curl  $url/WebService
  curl  $url/WebService/client
  curl  $url/WebService/routes?sort=true
  curl "$url/WebService?to=json&pretty=true&sort=true"
  curl  $url/WebService?to=yaml
  curl "$url/WebService?to=xml&pretty=false"
  curl "$url/WebService?to=xml&pretty=true"
  curl  $url/WebService?to=human
  curl  $url/WebService?to=perl
  curl  $url

=head1 Application routes

Based on the code of our TestService ( lib/TestService.pm ) some examples of how to login, logout, and route usage

  curl "$url/mirror?from=json&to=json&k1=a&k2=b"  -d '{"k1" : ["one","two","three"]}'
  curl "$url/mirror?to=xml&pretty=true"           -d '{"k1" : ["one","two","three"]}'
  curl "$url/mirror?from=yaml&to=perl"            -d '"k1"  : ["one","two","three"]'
  curl "$url/mirror?from=xml&to=yaml"             -d 'onetwo'

Login

  curl -X POST $url/login -H "$H" -d '{"username": "user1", "password": "s3cr3T+PA55sW0rD"}'

Protected application routes

  curl  $url/text
  curl  $url/text?token=17393926-5c8-0
  curl  $url/session_save?token=17393926-5c8-0 -H "$H" -X POST -d '{"k1":"v1", "k2":"v2", "k3":"v3"}'
  curl  $url/session_read?token=17393926-5c8-0
  curl  $url/session_delete?token=17393926-5c8-0 -H "$H" -X DELETE -d '["k3","k8","k9"]'
  curl  $url/session_read?token=17393926-5c8-0

Logout

  curl  $url/logout?token=17393926-5c8-0
  curl  $url/logout -d '{"token":"17393926-5c8-0"}' -H "$H" -X POST

=head1 Plugin Installation

You should your run your APIs as a non privileged user e.g. the "dancer"

  getent group  dancer >/dev/null || groupadd dancer
  getent passwd dancer >/dev/null || useradd -g dancer -l -m -c "Dancer2 WebService" -s $(which nologin) dancer
  i=/var/lib/WebService; [ -d $i ] || { mkdir $i; chown -R dancer:dancer $i; }
  i=/var/log/WebService; [ -d $i ] || { mkdir $i; chown -R dancer:dancer $i; }
  cpanm Dancer2
  cpanm Dancer2::Plugin::WebService

=head1 Create a sample application e.g. the "TestService"

Follow the I document to create the sample application I

=head1 Start the application

To start it manual as user I from the command line

=over 2

=item Production

  sudo -u dancer plackup --host 0.0.0.0 --port 3000 --server Starman --workers=5 --env development -a /home/dancer/TestService/bin/app.psgi

=item While developing

  sudo -u dancer plackup --host 0.0.0.0 --port 3000 --env development --app /home/dancer/TestService/bin/app.psgi --server HTTP::Server::PSGI

=back

view also the INSTALL document for details

=head1 Configure the loggger at the environment file

I

  log              : "debug"  # core, debug, info, warning, error
  show_stacktrace  : 0
  no_server_tokens : 1
  warnings         : 1          # should Dancer2 consider warnings as critical errors?
  show_errors      : 1          # if true shows a detailed debug error page , otherse the views/404.tt or public/404.html
  startup_info     : 1          # print the banner
  no_server_tokens : 1          # disable server tokens in production environments
  logger           : "file"     # console: to STDOUT , file:to file
  engines          :
    logger         :
      file         :
        log_format : '{"ts":"%T","host":"%h","pid":"%P","message":"%m"}'
        log_dir    : "/tmp"
        file_name  : "test.log"

=head1 See also

B Route PSGI requests for RESTful web applications

B A plugin for writing RESTful apps with Dancer2

B Perl extension for writing pRPC servers

B A simple, unified interface to XML-RPC and JSON-RPC

B Pure Perl implementation for an XML-RPC client and server.

B JSON RPC Server Implementation

=head1 AUTHOR

George Bouras

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2026 by George Bouras.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut

__END__