# Base library for portal tests
package main;

=pod

=encoding utf8

=head1 NAME

test-lib.pm - Test framework for LLNG portal

=head1 SYNOPSIS

  use Test::More;
  use strict;
  use IO::String;
  
  require 't/test-lib.pm';
  
  my $res;
  
  my $client = LLNG::Manager::Test->new( {
      ini => {
          logLevel => 'error',
          #...
      }
    }
  );
  
  ok(
      $res = $client->_post(
          '/',
          IO::String->new('user=dwho&password=dwho'),
          length => 23
      ),
      'Auth query'
  );
  count(1);
  expectOK($res);
  my $id = expectCookie($res);
  
  clean_sessions();
  done_testing( count() );

=head1 DESCRIPTION

This test library permits one to simulate browser navigation.

=head2 Functions

In these functions, C<$res> is the result of a C<LLNG::Manager::Test::_get()> or
C<LLNG::Manager::Test::_post()> call I<(see below)>.

=cut

use strict;
use Data::Dumper;
use File::Find;
use JSON;
use LWP::UserAgent;
use Time::Fake;
use URI::Escape;
use MIME::Base64;
use Lemonldap::NG::Common::FormEncode;
use Lemonldap::NG::Common::Util qw/getPSessionID/;

#use 5.10.0;

no warnings 'redefine';

BEGIN {
    use_ok('Lemonldap::NG::Portal::Main');
}

our $count = 1;
$Data::Dumper::Deparse  = 1;
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Useperl  = 1;
my $ini;

use File::Temp 'tempfile', 'tempdir';
use File::Copy 'copy';
our $tmpDir = $LLNG::TMPDIR
  || tempdir( 'tmpSessionXXXXX', DIR => 't/sessions', CLEANUP => 1 );
mkdir "$tmpDir/lock";
mkdir "$tmpDir/saml";
mkdir "$tmpDir/saml/lock";
copy( "t/lmConf-1.json", "$tmpDir/lmConf-1.json" );

=head4 count($inc)

Returns number of tests done. Increment test number if an argument is given

=cut

sub count {
    my $c = shift;
    $count += $c if ($c);
    return $count;
}

=head4 buildForm($params)

Convenience method that builds a url-encoded query string from a hash of arguments

=cut

sub buildForm {
    my $fields = shift;
    my $query  = join(
        '&',
        map {
            "$_="
              . (
                $fields->{$_}
                ? uri_escape( uri_unescape( $fields->{$_} ) )
                : ''
              )
          }
          keys(%$fields)
    );
    return $query;
}

=head4 explain( $result, $expected_result )

Used to display error if test fails:

  ok( $res->[0] == 302, 'Get redirection' ) or
    explain( $res->[0], 302 );

=cut

sub main::explain {
    my ( $get, $ref ) = @_;
    $get = Dumper($get) if ( ref $get );
    diag("Expect $ref, get $get\n");
}

=head4 clean_sessions()

Clean sessions created during tests

=cut

sub clean_sessions {
    find( sub { unlink if -f }, $tmpDir );
    foreach my $dir (qw(t/sessions/lock t/sessions/saml/lock t/sessions/saml)) {
        if ( -d $dir ) {
            opendir D, $dir or die $!;
            foreach ( grep { /^[^\.]/ } readdir(D) ) {
                unlink "$dir/$_";
            }
        }
    }
}

sub count_sessions {
    my ( $kind, $dir ) = @_;
    my $nbr = 0;
    $kind ||= 'SSO';
    $dir  ||= $tmpDir;

    opendir D, $dir or die $!;
    foreach ( grep { /^\w{64}$/ } readdir(D) ) {
        open( my $fh, '<', "$dir/$_" ) or die($!);
        while (<$fh>) {
            chomp;
            if ( $_ =~ /"_session_kind":"$kind"/ ) {
                $nbr++;
                last;
            }
        }
        close $fh;
    }
    $nbr;
}

sub getCache {
    require Cache::FileCache;
    return Cache::FileCache->new( {
            namespace   => 'lemonldap-ng-session',
            cache_root  => $tmpDir,
            cache_depth => 0,
        }
    );
}

sub getSession {
    my $id           = shift;
    my @sessionsOpts = (
        storageModule        => "Apache::Session::File",
        storageModuleOptions => {
            Directory     => "$tmpDir",
            LockDirectory => "$tmpDir/lock",
        },
        kind => 'SSO'
    );

    return Lemonldap::NG::Common::Session->new( {
            @sessionsOpts, id => $id,
        }
    );
}

sub getPSession {
    my $uid          = shift;
    my @sessionsOpts = (
        storageModule        => "Apache::Session::File",
        storageModuleOptions => {
            Directory     => "$tmpDir",
            LockDirectory => "$tmpDir/lock",
        },
        kind => 'Persistent'
    );

    return Lemonldap::NG::Common::Session->new( {
            @sessionsOpts, id => getPSessionID($uid),
        }
    );
}

=head4 expectRedirection( $res, $location )

Verify that request result is a redirection to $location. $location can be:

=over

=item a string: location must match exactly

=item a regexp: location must match this regexp. In this case, the list of
matching strings are returned. Example:

  my( $uri, $query ) = expectRedirection( $res, qr#http://host(/[^\?]*)?(.*)$# );

=back

=cut

sub expectRedirection {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ( $res, $location ) = @_;
    ok( $res->[0] == 302, ' Get redirection' )
      or explain( $res->[0], 302 );
    count(1);
    if ( ref $location ) {
        my @match;
        @match = ( getRedirection($res) =~ $location );
        ok( @match, ' Location header found' )
          or explain( $res->[1], "Location match: " . Dumper($location) );
        count(1);
        return @match;
    }
    else {
        ok( getRedirection($res) eq $location, " Location is $location" )
          or explain( $res->[1], "Location => $location" );
        count(1);
    }
}

=head4 expectAutoPost(@args)

Same behaviour as C<expectForm()> but verify also that form method is post.

TODO: verify javascript

=cut

sub expectAutoPost {
    local $Test::Builder::Level = $Test::Builder::Level + 1;

    my @r      = expectForm(@_);
    my $method = pop @r;
    ok( $method =~ /^post$/i, ' Method is POST' ) or explain( $method, 'POST' );
    count(1);
    return @r;
}

=head4 expectForm( $res, $hostRe, $uriRe, @requiredFields )

Verify form in HTML result and return ( $host, $uri, $query, $method ):

=over

=item verify that a GET/POST form exists

=item if a $hostRe regexp is given, verify that form target matches and
populates $host. Skipped if $hostRe eq "#"

=item if a $uriRe regexp is given, verify that form target matches and
populates $uri

=item if @requiredFields exists, verify that each element is an input name

=item build form-url-encoded string looking at parameters/values and store it
in $query

=back

=cut

sub expectForm {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ( $res, $hostRe, $uriRe, @requiredFields ) = @_;
    expectOK($res);
    count(1);
    if (
        ok(
            $res->[2]->[0] =~
m@<form.+?action="(?:(?:http://([^/]+))?(/.*?)?|(#))".+method="(post|get)"@is,
            ' Page contains a form'
        )
      )
    {
        my ( $host, $uri, $hash, $method ) = ( $1, $2, $3, $4 );
        if ( $hash and $hash eq '#' ) {
            $host = '#';
            $uri  = '';
        }
        if ($hostRe) {
            if ( ref $hostRe ) {
                ok( $host =~ $hostRe, ' Host match' )
                  or explain( $host, $hostRe );
            }
            else {
                ok( $host eq $hostRe, ' Host match' )
                  or explain( $host, $hostRe );
            }
            count(1);
        }
        if ($uriRe) {
            if ( ref $uriRe ) {
                ok( $uri =~ $uriRe, ' URI match' ) or explain( $uri, $uriRe );
            }
            else {
                ok( $uri eq $uriRe, ' URI match' ) or explain( $uri, $uriRe );
            }
            count(1);
        }

        # Fields with values
        my %fields =
          ( $res->[2]->[0] =~
              m#<input.+?name="([^"]+)"[^>]+(?:value="([^"]*?)")#gs );

        # Add fields without values
        %fields = (
            $res->[2]->[0] =~
              m#<input.+?name="([^"]+)"[^>]+(?:value="([^"]*?)")?#gs,
            %fields
        );

        # Add textarea
        %fields = (
            $res->[2]->[0] =~
              m#<textarea.+?name="([^"]+)"[^>]+(?:value="([^"]*?)")?#gs,
            %fields
        );
        my $query = buildForm( \%fields );
        foreach my $f (@requiredFields) {
            ok( exists $fields{$f}, qq{ Field "$f" is defined} );
            count(1);
        }
        exceptCspFormOK( $res, $host );
        return ( $host, $uri, $query, $method );
    }
    else {
        return ();
    }
}

=head4 expectAuthenticatedAs($user)

Verify that result has a C<Lm-Remote-User> header and value is $user

=cut

sub expectAuthenticatedAs {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ( $res, $user ) = @_;
    is( getHeader( $res, 'Lm-Remote-User' ), $user, "Authenticated as $user" );
    count(1);
}

=head4 expectSessionAttributes($app,$id,%attributes)

Verify that the session contains attributes with these values

=cut

sub expectSessionAttributes {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ( $app, $id, %attributes ) = @_;
    my $res;
    ok(
        $res = $app->_get("/sessions/global/$id"),
        "Get session using restSessionServer"
    );
    count(1);
    expectOK($res);
    ok( $res = eval { from_json( $res->[2]->[0] ) },
        "Deserialize session content" );
    count(1);
    for my $attr ( keys %attributes ) {
        is( $res->{$attr}, $attributes{$attr},
            "Session has correct value for $attr" );
        count(1);
    }
}

=head4 expectOK($res)

Verify that returned code is 200

=cut

sub expectOK {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ($res) = @_;
    ok( $res->[0] == 200, ' HTTP code is 200' ) or explain( $res, 200 );
    count(1);
}

=head4 expectJSON($res)

Verify that the HTTP response contains valid JSON and returns the corresponding object

=cut

sub expectJSON {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ($res) = @_;
    is( $res->[0], 200, ' HTTP code is 200' ) or explain( $res, 200 );
    my %hdr = @{ $res->[1] };
    like( $hdr{'Content-Type'}, qr,^application/json,i,
        ' Content-Type is JSON' )
      or explain($res);
    my $json;
    eval { $json = JSON::from_json( $res->[2]->[0] ) };
    ok( not($@), 'Content is valid JSON' );
    count(3);
    return $json;
}

=head4 expectForbidden($res)

Verify that returned code is 403.

=cut

sub expectForbidden {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ($res) = @_;
    ok( $res->[0] == 403, ' HTTP code is 403' ) or explain( $res->[0], 403 );
    count(1);
}

=head4 expectBadRequest($res)

Verify that returned code is 400. Note that it works only for Ajax request
(see below).

=cut

sub expectBadRequest {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ($res) = @_;
    ok( $res->[0] == 400, ' HTTP code is 400' ) or explain( $res->[0], 400 );
    count(1);
}

=head4 expectPortalError( $res, $errnum )

Verify that an error is displayed on the portal
=cut

sub expectPortalError {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ( $res, $errnum, $message ) = @_;
    $errnum ||= 9;
    like( $res->[2]->[0], qr/<span trmsg="$errnum">/, $message );
    count(1);
}

=head4 expectReject( $res, $status, $code )

Verify that returned code is 401 (or $status)  and JSON result contains
C<error:"$code">.  Note that it works only for Ajax request (see below).

=cut

sub expectReject {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ( $res, $status, $code ) = @_;
    $status ||= 401;
    cmp_ok( $res->[0], '==', $status, " Response status is $status" );
    eval { $res = JSON::from_json( $res->[2]->[0] ) };
    ok( not($@), ' Content is JSON' )
      or explain( $res->[2]->[0], 'JSON content' );
    if ( defined $code ) {
        is( $res->{error}, $code, " Error code is $code" );
    }
    else {
        pass("Error code is $res->{error}");
    }
    count(3);
}

=head4 expectCookie( $res, $cookieName )

Check if a C<Set-Cookie> exists and set a cookie named $cookieName. Return
its value.

=cut

sub expectCookie {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ( $res, $cookieName ) = @_;
    $cookieName ||= 'lemonldap';
    my $cookies = getCookies($res);
    my $id;
    ok(
        defined( $id = $cookies->{$cookieName} ),
        " Get cookie $cookieName ($id)"
    ) or explain( $res->[1], "Set-Cookie: $cookieName=something" );
    count(1);
    return $id;
}

=head4 expectPdata( $res );

Check if the pdata cookie exists and returns its deserialized value.

=cut

sub expectPdata {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ($res) = @_;
    my $val = expectCookie( $res, "lemonldappdata" );
    ok( $val, "Pdata is not empty" );
    count(1);
    my $pdata;
    eval { $pdata = JSON::from_json( uri_unescape($val) ); };
    diag($@) if $@;
    return $pdata;
}

=head4 exceptCspFormOK( $res, $host )

Verify that C<Content-Security-Policy> header allows one to connect to $host.

=cut

sub exceptCspFormOK {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ( $res, $host ) = @_;
    return 1 unless ($host);
    my $csp = getHeader( $res, 'Content-Security-Policy' );
    return 1 unless ($csp);
    unless ( $csp =~ s/^.*form-action (.*?)(?:;.*)?$/$1/ ) {
        $csp =~ s/^.*default-src (.*?)(?:;.*)?$/$1/;
    }
    if (   $csp =~ /\s\*(?:\s.*)?\s*$/
        or ( $host eq '#' and $csp =~ /'self'/ )
        or $csp =~ m#\bhttps?://$host\b#
        or $csp =~ m#\*# )
    {
        pass(" CSP header authorize POST request to $host");
    }
    else {
        fail(" CSP header authorize POST request to $host");
        explain( $res->[1], "form-action ... $host" );
    }
    count(1);
}

sub expectCspChildOK {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ( $res, $host ) = @_;
    return 1 unless ($host);
    my $csp = getHeader( $res, 'Content-Security-Policy' );
    ok( $csp, "Content-Security-Policy header found" );
    count(1);
    like( $csp, qr/child-src[^;]*\Q$host\E/, "Found $host in CSP child-src" );
    count(1);
}

=head4 getCookies($res)

Returns an hash ref with names => values of cookies set by server.

=cut

sub getCookies {
    my ($resp) = @_;
    my @hdrs   = @{ $resp->[1] };
    my $res    = {};
    while ( my $name = shift @hdrs ) {
        my $v = shift @hdrs;
        if ( $name eq 'Set-Cookie' ) {
            if ( $v =~ /^(\w+)=([^;]*)/ ) {
                $res->{$1} = $2;
            }
        }
    }
    return $res;
}

=head4 getHeader( $res, $hname )

Returns value of first header named $hname in $res response.

=cut

sub getHeader {
    my ( $resp, $hname ) = @_;
    my @hdrs = @{ $resp->[1] };
    my $res  = {};
    while ( my $name = shift @hdrs ) {
        my $v = shift @hdrs;
        if ( $name eq $hname ) {
            return $v;
        }
    }
    return undef;
}

=head4 getRedirection($res)

Returns value of C<Location> header.

=cut

sub getRedirection {
    my ($resp) = @_;
    return getHeader( $resp, 'Location' );
}

=head4 getUser($res)

Returns value of C<Lm-Remote-User> header.

=cut

sub getUser {
    my ($resp) = @_;
    return getHeader( $resp, 'Lm-Remote-User' );
}

=head4 tempdb

Return a temporary file named XXXX.db

=cut

sub tempdb {
    return "$tmpDir/userdb.db";
}

my %handlerOR;

=head4 register

Registers a new LLNG instance

=cut

sub register {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ( $type, $constructor ) = @_;
    my $obj;
    @Lemonldap::NG::Handler::Main::_onReload = ();
    &Lemonldap::NG::Handler::Main::cfgNum( 0, 0 );
    ok( $obj = $constructor->(), 'Register $type' );
    count(1);
    $handlerOR{$type} = \@Lemonldap::NG::Handler::Main::_onReload;
    return $obj;
}

=head4 register

Switch to a registered instance

=cut

sub switch {
    my $type = shift;
    return [] unless $handlerOR{$type};
    note( '==> Switching to ' . uc($type) . ' <==' );
    @Lemonldap::NG::Handler::Main::_onReload = @{
        $handlerOR{$type};
    };
}

=head4 encodeUrl( $url );

Encode URL like the handler would, see ::Handler::Main

=cut

sub encodeUrl {
    my ($url) = @_;
    return uri_escape( encode_base64( $url, '' ) );
}

=head2 LLNG::Manager::Test Class

=cut

package LLNG::Manager::Test;

use strict;
use Mouse;

extends 'Lemonldap::NG::Common::PSGI::Cli::Lib';

# try to find template dir in @INC
my $templateDir = "site/templates";
unless ( -d $templateDir ) {
    for (@INC) {
        if ( -d "$_/site/templates" ) {
            $templateDir = "$_/site/templates";
            last;
        }
    }
    unless ( -d $templateDir ) {
        die "Could not find template dir";
    }
}

our $defaultIni = {
    configStorage => {
        type    => 'File',
        dirName => "$tmpDir",
    },
    localSessionStorage        => 'Cache::FileCache',
    localSessionStorageOptions => {
        namespace   => 'lemonldap-ng-session',
        cache_root  => $tmpDir,
        cache_depth => 0,
    },
    logLevel              => 'error',
    cookieName            => 'lemonldap',
    domain                => 'example.com',
    templateDir           => $templateDir,
    staticPrefix          => '/static',
    tokenUseGlobalStorage => 0,
    securedCookie         => 0,

    # If lasso is too old, force algo to SHA1
    (
        eval
'use Lasso; Lasso::check_version( 2, 5, 1, Lasso::Constants::CHECK_VERSION_NUMERIC) ? 0:1'
        ? ( samlServiceSignatureMethod => "RSA_SHA1" )
        : ()
    ),
    https                => 0,
    globalStorageOptions => {
        Directory      => $tmpDir,
        LockDirectory  => "$tmpDir/lock",
        generateModule =>
          'Lemonldap::NG::Common::Apache::Session::Generate::SHA256',
    },
    casStorageOptions => {
        Directory      => "$tmpDir/saml",
        LockDirectory  => "$tmpDir/saml/lock",
        generateModule =>
          'Lemonldap::NG::Common::Apache::Session::Generate::SHA256',
    },
    samlStorageOptions => {
        Directory      => "$tmpDir/saml",
        LockDirectory  => "$tmpDir/saml/lock",
        generateModule =>
          'Lemonldap::NG::Common::Apache::Session::Generate::SHA256',
    },
    oidcStorageOptions => {
        Directory      => "$tmpDir/saml",
        LockDirectory  => "$tmpDir/saml/lock",
        generateModule =>
          'Lemonldap::NG::Common::Apache::Session::Generate::SHA256',
    },
};

=head3 Accessors

=over

=item app: built application

=cut

has app => (
    is  => 'rw',
    isa => 'CodeRef',
);

=item class: class to test (default Lemonldap::NG::Portal::Main)

=cut

has class => ( is => 'ro', default => 'Lemonldap::NG::Portal::Main' );

=item p: portal object

=cut

has p => ( is => 'rw' );

=item ini: initialization parameters ($defaultIni values + given parameters)

=cut

has confFailure => ( is => 'rw' );

has ini => (
    is      => 'rw',
    lazy    => 1,
    default => sub { $defaultIni; },
    trigger => sub {
        my ( $self, $ini ) = @_;
        foreach my $k ( keys %$defaultIni ) {
            $ini->{$k} //= $defaultIni->{$k};
        }
        $self->{ini} = $ini;
        main::ok( $self->{p} = $self->class->new(), 'Portal object' );
        main::count(1);
        unless ( $self->confFailure ) {
            main::ok( $self->{p}->init($ini),           'Init' );
            main::ok( $self->{app} = $self->{p}->run(), 'Portal app' );
            main::count(2);
            no warnings 'redefine';
            eval
'sub Lemonldap::NG::Common::Logger::Std::error {return $_[0]->warn($_[1])}';
            $Lemonldap::NG::Portal::UserDB::Demo::demoAccounts{french} = {
                uid  => 'french',
                cn   => 'Frédéric Accents',
                mail => 'fa@badwolf.org',
                guy  => '',
                type => '',
            };
            $Lemonldap::NG::Portal::UserDB::Demo::demoAccounts{russian} = {
                uid  => 'russian',
                cn   => 'Русский',
                mail => 'ru@badwolf.org',
                guy  => '',
                type => '',
            };
            $Lemonldap::NG::Portal::UserDB::Demo::demoAccounts{davros} = {
                uid  => 'davros',
                cn   => 'Bad Guy',
                mail => 'davros@badguy.org',
                guy  => 'bad',
                type => 'character',
            };
            $Lemonldap::NG::Portal::UserDB::Demo::demoAccounts{dalek} = {
                uid  => 'dalek',
                cn   => 'The Daleks',
                mail => 'dalek@badguy.org',
                guy  => 'bad',
                type => 'mutant',
            };
            push
              @{ $Lemonldap::NG::Portal::UserDB::Demo::demoGroups{earthlings} },
              "french", "russian";
            push @{ $Lemonldap::NG::Portal::UserDB::Demo::demoGroups{users} },
              "french", "russian", "davros";
        }
        $self;
    }
);

=back

=head3 Methods

=head4 logout($id)

Launch a C</?logout=1> request an test:

=over

=item if response is 200

=item if cookie $cookieName and "${cookieName}pdata" have no value

=item if a GET request with previous cookie value I<($i)> is rejected

=back

=cut

sub logout {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ( $self, $id, $cookieName ) = @_;
    my $res;
    $cookieName ||= 'lemonldap';

    main::ok(
        $res = $self->_get(
            '/',
            query  => 'logout',
            cookie => "$cookieName=$id",
            accept => 'text/html'
        ),
        'Logout request'
    );
    main::ok( $res->[0] == 200, ' Response is 200' )
      or main::explain( $res->[0], 200 );
    my $c;
    main::ok(
        ( defined( $c = main::getCookies($res)->{$cookieName} ) and not $c ),
        ' Cookie is deleted' )
      or main::explain( $res->[1], "Set-Cookie => 'lemonldap='" );
    main::ok( not( main::getCookies($res)->{"${cookieName}pdata"} ),
        ' No pdata' );
    main::ok( $res = $self->_get( '/', cookie => "$cookieName=$id" ),
        'Disconnect request' )
      or explain( $res, '[<code>,<hdrs>,<content>]' );
    main::ok( $res->[0] == 401, ' Response is 401' )
      or main::explain( $res, 401 );
    main::count(6);

}

=head4 _get( $path, %args )

Simulates a GET requests to $path. Accepted arguments:

=over

=item accept: accepted content, default to Ajax request. Use 'text/html'
to test content I<(to launch a C<expectForm()> for example)>.

=item cookie: full cookie string

=item custom: additional headers (hash ref only)

=item ip: remote address. Default to 127.0.0.1

=item method: default to GET. Only GET/DELETE values are acceptable
(use C<_post()> if you want to launch a POST/PUT request)

=item query: query string

=item referer

=item remote_user: REMOTE_USER header value

=back

=cut

sub _get {
    my ( $self, $path, %args ) = @_;
    my $res = $self->app->( {
            'HTTP_ACCEPT' => $args{accept}
              || 'application/json, text/plain, */*',
            'HTTP_ACCEPT_LANGUAGE' => 'fr,fr-FR;q=0.8,en-US;q=0.5,en;q=0.3',
            'HTTP_CACHE_CONTROL'   => 'max-age=0',
            ( $args{cookie} ? ( HTTP_COOKIE => $args{cookie} ) : () ),
            'HTTP_HOST' => ( $args{host} ? $args{host} : 'auth.example.com' ),
            'HTTP_USER_AGENT' =>
              'Mozilla/5.0 (VAX-4000; rv:36.0) Gecko/20350101 Firefox',
            'PATH_INFO' => $path,
            ( $args{referer} ? ( REFERER => $args{referer} ) : () ),
            (
                $args{ip} ? ( 'REMOTE_ADDR' => $args{ip} )
                : ( 'REMOTE_ADDR' => '127.0.0.1' )
            ),
            (
                $args{remote_user} ? ( 'REMOTE_USER' => $args{remote_user} )
                : ()
            ),
            'REQUEST_METHOD' => $args{method} || 'GET',
            'REQUEST_URI'    => $path . ( $args{query} ? "?$args{query}" : '' ),
            ( $args{query} ? ( QUERY_STRING => $args{query} ) : () ),
            'SCRIPT_NAME'     => '',
            'SERVER_NAME'     => 'auth.example.com',
            'SERVER_PORT'     => '80',
            'SERVER_PROTOCOL' => 'HTTP/1.1',
            'psgi.url_scheme' => ( $args{secure} ? 'https' : 'http' ),
            ( $args{custom} ? %{ $args{custom} } : () ),
        }
    );
    return $res;
}

=head4 _post( $path, $body, %args )

Same as C<_get> except that a body is required. $body must be a file handle.
Example with IO::String:

  ok(
      $res = $client->_post(
          '/',
          IO::String->new('user=dwho&password=dwho'),
          length => 23
      ),
      'Auth query'
  );

=cut

sub _post {
    my ( $self, $path, $body, %args ) = @_;
    die "$body must be a IO::Handle"
      unless ( ref($body) and $body->can('read') );
    my $res = $self->app->( {
            'HTTP_ACCEPT' => $args{accept}
              || 'application/json, text/plain, */*',
            'HTTP_ACCEPT_LANGUAGE' => 'fr,fr-FR;q=0.8,en-US;q=0.5,en;q=0.3',
            'HTTP_CACHE_CONTROL'   => 'max-age=0',
            ( $args{cookie} ? ( HTTP_COOKIE => $args{cookie} ) : () ),
            'HTTP_HOST' => ( $args{host} ? $args{host} : 'auth.example.com' ),
            'HTTP_USER_AGENT' =>
              'Mozilla/5.0 (VAX-4000; rv:36.0) Gecko/20350101 Firefox',
            'PATH_INFO' => $path,
            ( $args{query}   ? ( QUERY_STRING => $args{query} )   : () ),
            ( $args{referer} ? ( REFERER      => $args{referer} ) : () ),
            (
                $args{ip} ? ( 'REMOTE_ADDR' => $args{ip} )
                : ( 'REMOTE_ADDR' => '127.0.0.1' )
            ),
            (
                $args{remote_user} ? ( 'REMOTE_USER' => $args{remote_user} )
                : ()
            ),
            'REQUEST_METHOD' => $args{method} || 'POST',
            'REQUEST_URI'    => $path . ( $args{query} ? "?$args{query}" : '' ),
            'SCRIPT_NAME'    => '',
            'SERVER_NAME'    => 'auth.example.com',
            'SERVER_PORT'    => '80',
            'SERVER_PROTOCOL' => 'HTTP/1.1',
            'psgi.url_scheme' => ( $args{secure} ? 'https' : 'http' ),
            ( $args{custom} ? %{ $args{custom} } : () ),
            'psgix.input.buffered' => 0,
            'psgi.input'           => $body,
            'CONTENT_LENGTH' => $args{length} // scalar( ( stat $body )[7] ),
            'CONTENT_TYPE'   => $args{type}
              || 'application/x-www-form-urlencoded',
        }
    );
    return $res;
}

=head4 _delete( $path, %args )

Call C<_get()> with method set to DELETE.

=cut

sub _delete {
    my ( $self, $path, %args ) = @_;
    $args{method} = 'DELETE';
    $self->_get( $path, %args );
}

=head4 _options( $path, %args )

Call C<_get()> with method set to OPTIONS.

=cut

sub _options {
    my ( $self, $path, %args ) = @_;
    $args{method} = 'OPTIONS';
    $self->_get( $path, %args );
}

=head4 _put( $path, $body, %args )

Call C<_post()> with method set to PUT

=cut

sub _put {
    my ( $self, $path, $body, %args ) = @_;
    $args{method} = 'PUT';
    return $self->_post( $path, $body, %args );
}

1;