#!/usr/local/bin/perl
BEGIN
{
use
vars
qw( $DEBUG $VERSION $hostport $host $port $mp_host $proto $ua @ua_args )
;
use
constant
HAS_APACHE_TEST
=>
$ENV
{HAS_APACHE_TEST};
if
( HAS_APACHE_TEST )
{
use_ok(
'Apache2::API'
) || BAIL_OUT(
"Unable to load Apache2::API"
);
use_ok(
'Apache2::Const'
,
qw( -compile :common :http )
) || BAIL_OUT(
"Unable to load Apache2::Const"
);
require_ok(
'Apache::Test'
) || BAIL_OUT(
"Unable to load Apache::Test"
);
use_ok(
'Apache::TestUtil'
) || BAIL_OUT(
"Unable to load Apache::TestUtil"
);
use_ok(
'Apache::TestRequest'
) || BAIL_OUT(
"Unable to load Apache::TestRequest"
);
use_ok(
'HTTP::Request'
) || BAIL_OUT(
"Unable to load HTTP::Request"
);
use_ok(
'JSON'
) || BAIL_OUT(
"Unable to load JSON"
);
plan no_plan;
}
else
{
plan
skip_all
=>
'Not running under modperl'
;
}
our
$DEBUG
=
exists
(
$ENV
{API_DEBUG} ) ?
$ENV
{API_DEBUG} :
exists
(
$ENV
{AUTHOR_TESTING} ) ?
$ENV
{AUTHOR_TESTING} : 0;
our
$VERSION
=
'v0.1.0'
;
our
(
$hostport
,
$host
,
$port
,
$mp_host
,
$proto
,
$ua
);
require
(
"./t/env.pl"
)
if
( -e(
"t/env.pl"
) );
};
BEGIN
{
if
( HAS_APACHE_TEST )
{
my
$config
= Apache::Test::config();
$hostport
= Apache::TestRequest::hostport(
$config
) ||
''
;
(
$host
,
$port
) =
split
(
':'
, (
$hostport
) );
$mp_host
=
'www.example.org'
;
our
@ua_args
= (
agent
=>
'Test-Apache2-API/'
.
$VERSION
,
cookie_jar
=> {},
default_headers
=> HTTP::Headers->new(
Host
=>
"${mp_host}:${port}"
,
Accept
=>
'application/json; version=1.0; charset=utf-8, text/javascript, */*'
,
Accept_Encoding
=>
'gzip, deflate, br'
,
Accept_Language
=>
'en-GB,fr-FR;q=0.8,fr;q=0.6,ja;q=0.4,en;q=0.2'
,
),
keep_alive
=> 1,
);
Apache::TestRequest::user_agent(
@ua_args
,
reset
=> 1 );
$ua
= Apache::TestRequest->new(
@ua_args
);
$ua
->ssl_opts(
SSL_fingerprint
=>
'sha1$DEE8650E44870896E821AAE4A5A24382174D100E'
,
);
}
$proto
= HAS_SSL ?
'https'
:
'http'
;
diag(
"Host: '$host', port '$port'"
)
if
(
$DEBUG
);
};
our
$config
= Apache::TestConfig->thaw->httpd_config;
die
(
"No directory \"t/logs\""
)
if
( !
$config
->{vars}->{t_logs} || !-e(
$config
->{vars}->{t_logs} ) );
our
$logs_dir
= file(
$config
->{vars}->{t_logs} );
our
$target2path
=
{
api
=>
$logs_dir
->child(
'apache2/api'
),
request
=>
$logs_dir
->child(
'apache2/api/request'
),
response
=>
$logs_dir
->child(
'apache2/api/response'
),
};
my
$jwt
=
q{eyJleHAiOjE2MzYwNzEwMzksImFsZyI6IkhTMjU2In0.eyJqdGkiOiJkMDg2Zjk0OS1mYWJmLTRiMzgtOTE1ZC1hMDJkNzM0Y2ZmNzAiLCJmaXJzdF9uYW1lIjoiSm9obiIsImlhdCI6MTYzNTk4NDYzOSwiYXpwIjoiNGQ0YWFiYWQtYmJiMy00ODgwLThlM2ItNTA0OWMwZTczNjBlIiwiaXNzIjoiaHR0cHM6Ly9hcGkuZXhhbXBsZS5jb20iLCJlbWFpbCI6ImpvaG4uZG9lQGV4YW1wbGUuY29tIiwibGFzdF9uYW1lIjoiRG9lIiwic3ViIjoiYXV0aHxlNzg5OTgyMi0wYzlkLTQyODctYjc4Ni02NTE3MjkyYTVlODIiLCJjbGllbnRfaWQiOiJiZTI3N2VkYi01MDgzLTRjMWEtYTM4MC03Y2ZhMTc5YzA2ZWQiLCJleHAiOjE2MzYwNzEwMzksImF1ZCI6IjRkNGFhYmFkLWJiYjMtNDg4MC04ZTNiLTUwNDljMGU3MzYwZSJ9.VSiSkGIh41xXIVKn9B6qGjfzcLlnJAZ9jGOPVgXASp0}
;
subtest
'core'
=>
sub
{
my
(
$req
,
$resp
);
&simple_test
({
target
=>
'api'
,
name
=>
'compression_threshold'
,
code
=> Apache2::Const::HTTP_OK });
&simple_test
({
target
=>
'api'
,
name
=>
'decode_json'
,
code
=> Apache2::Const::HTTP_OK });
&simple_test
({
target
=>
'api'
,
name
=>
'encode_decode_url'
,
code
=> Apache2::Const::HTTP_OK });
&simple_test
({
target
=>
'api'
,
name
=>
'auth'
,
code
=> Apache2::Const::HTTP_OK,
headers
=> [
Authorization
=>
"Bearer: $jwt"
] });
&simple_test
({
target
=>
'api'
,
name
=>
'header_datetime'
,
code
=> Apache2::Const::HTTP_OK });
&simple_test
({
target
=>
'api'
,
name
=>
'is_perl_option_enabled'
,
code
=> Apache2::Const::HTTP_OK });
&simple_test
({
target
=>
'api'
,
name
=>
'json'
,
code
=> Apache2::Const::HTTP_OK });
$resp
=
&make_request
(
api
=>
'reply'
);
my
$j
= JSON->new;
my
$content
=
$resp
->decoded_content;
diag(
"test 'reply' decoded_content is '$content'"
)
if
(
$DEBUG
);
my
$ref
;
eval
{
$ref
=
$j
->decode(
$content
);
};
ok(
ref
(
$ref
) eq
'HASH'
,
'reply -> JSON decoded content is an hash reference'
);
is(
$resp
->code, Apache2::Const::HTTP_OK,
'reply code'
);
is(
$ref
->{message},
'ok'
,
'reply message'
);
&simple_test
({
target
=>
'api'
,
name
=>
'server'
,
code
=> Apache2::Const::HTTP_OK });
&simple_test
({
target
=>
'api'
,
name
=>
'server_version'
,
code
=> Apache2::Const::HTTP_OK });
};
subtest
'request'
=>
sub
{
my
@tests
=
qw(
aborted accept accept_charset accept_encoding accept_language accept_type
accept_version acceptable acceptables allowed as_string auto_header
charset client_api_version connection decode encode document_root
document_uri env finfo gateway_interface global_request has_auth header_only
headers headers_as_hashref headers_as_json headers_in is_secure json local_addr
method mod_perl_version no_cache notes path_info
preferred_language protocol remote_addr request_time server
socket subprocess_env the_request time2str type uri user_agent
)
;
foreach
my
$test
(
@tests
)
{
&simple_test
({
target
=>
'request'
,
name
=>
$test
,
code
=> Apache2::Const::HTTP_OK });
}
my
(
$req
,
$resp
);
&simple_test
({
target
=>
'request'
,
name
=>
'args'
,
code
=> Apache2::Const::HTTP_OK,
query
=>
'foo=1&foo=2&bar=3&lang=ja_JP'
});
&simple_test
({
target
=>
'request'
,
name
=>
'auth'
,
code
=> Apache2::Const::HTTP_OK,
headers
=> [
Authorization
=>
"Bearer: $jwt"
] });
&simple_test
({
target
=>
'request'
,
name
=>
'body'
,
code
=> Apache2::Const::HTTP_OK,
headers
=> [
Content_Type
=>
"application/x-www-form-urlencoded"
],
body
=>
q{a=a1&b=b1&b=b2&c=foo+&tengu=%E5%A4%A9%E7%8B%97}
,
http_method
=>
'post'
});
&simple_test
({
target
=>
'request'
,
name
=>
'cookie'
,
code
=> Apache2::Const::HTTP_OK,
headers
=> [
Cookie
=>
"my_session=foo"
] });
my
$data_body
=
<<EOT;
{
"id": 123,
"client_id": "37c58138-e259-44aa-9eee-baf3cbecca75"
}
EOT
&simple_test
({
target
=>
'request'
,
name
=>
'data'
,
code
=> Apache2::Const::HTTP_OK,
headers
=> [
Content_Type
=>
'application/json; charset=utf-8'
],
body
=>
$data_body
,
http_method
=>
'post'
});
&simple_test
({
target
=>
'request'
,
name
=>
'param'
,
code
=> Apache2::Const::HTTP_OK,
query
=>
'foo=bar&lang=ja_JP'
});
&simple_test
({
target
=>
'request'
,
name
=>
'params'
,
code
=> Apache2::Const::HTTP_OK,
query
=>
'foo=bar&lang=ja_JP'
});
&simple_test
({
target
=>
'request'
,
name
=>
'payload'
,
code
=> Apache2::Const::HTTP_OK,
headers
=> [
Content_Type
=>
'application/json; charset=utf-8'
],
body
=>
$data_body
,
http_method
=>
'post'
});
&simple_test
({
target
=>
'request'
,
name
=>
'query'
,
code
=> Apache2::Const::HTTP_OK,
query
=>
'foo=1&bar=3&lang=ja_JP'
});
&simple_test
({
target
=>
'request'
,
name
=>
'query_string'
,
code
=> Apache2::Const::HTTP_OK,
query
=>
'foo=bar&lang=ja-JP&q=%E6%9C%80%E9%AB%98%E3%81%A0%EF%BC%81'
});
};
subtest
'response'
=>
sub
{
my
@tests
=
qw(
headers headers_out make_etag no_cache no_local_copy sendfile set_last_modified
socket
)
;
foreach
my
$test
(
@tests
)
{
&simple_test
({
target
=>
'response'
,
name
=>
$test
,
code
=> Apache2::Const::HTTP_OK });
}
};
sub
make_request
{
my
(
$type
,
$path
,
$opts
) =
@_
;
my
$http_meth
=
uc
(
$opts
->{http_method} //
'GET'
);
my
$req
= HTTP::Request->new(
$http_meth
=>
"${proto}://${hostport}/tests/${type}/${path}"
,
(
exists
(
$opts
->{headers} ) ?
$opts
->{headers} : () ),
( (
exists
(
$opts
->{body} ) &&
length
(
$opts
->{body} //
''
) ) ?
$opts
->{body} : () ),
);
if
(
$opts
->{query} )
{
my
$u
= URI->new(
$req
->uri );
$u
->query(
$opts
->{query} );
$req
->uri(
$u
);
}
unless
(
$req
->header(
'Content-Type'
) )
{
$req
->header(
Content_Type
=>
'text/plain; charset=utf-8'
);
}
diag(
"Request for $path is: "
,
$req
->as_string )
if
(
$DEBUG
);
my
$resp
=
$ua
->request(
$req
);
diag(
"Server response for $path is: "
,
$resp
->as_string )
if
(
$DEBUG
);
return
(
$resp
);
}
sub
simple_test
{
my
$opts
=
shift
(
@_
);
if
( !
$opts
->{name} )
{
die
(
"No test name was provided."
);
}
elsif
( !
defined
(
$opts
->{code} ) )
{
die
(
"No HTTP code was provided."
);
}
elsif
( !
defined
(
$opts
->{target} ) )
{
die
(
"No test target was provided. It should be 'api', 'request' or 'response'"
);
}
my
$resp
=
&make_request
(
$opts
->{target} =>
$opts
->{name},
$opts
);
is(
$opts
->{code}, Apache2::Const::HTTP_OK,
$opts
->{name} ) ||
diag(
"Error with test \"$opts->{name}\". See log content below:\n"
,
&get_log
(
$opts
) );
}
sub
get_log
{
my
$opts
=
shift
(
@_
);
my
$log_file
=
$target2path
->{
$opts
->{target} }->child(
$opts
->{name} .
'.log'
);
if
(
$log_file
->
exists
)
{
return
(
$log_file
->load_utf8 );
}
else
{
diag(
"Test $opts->{target} -> $opts->{name} seems to have failed, but there is no log file \"$log_file\""
);
}
}
done_testing();