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
;
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"
);
sub
count {
my
$c
=
shift
;
$count
+=
$c
if
(
$c
);
return
$count
;
}
sub
buildForm {
my
$fields
=
shift
;
my
$query
=
join
(
'&'
,
map
{
"$_="
. (
$fields
->{
$_
} ? uri_escape(
$fields
->{
$_
} ) :
''
) }
keys
(
%$fields
) );
return
$query
;
}
sub
main::explain {
my
(
$get
,
$ref
) =
@_
;
$get
= Dumper(
$get
)
if
(
ref
$get
);
diag(
"Expect $ref, get $get\n"
);
}
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 {
return
Cache::FileCache->new( {
namespace
=>
'lemonldap-ng-session'
,
cache_root
=>
$tmpDir
,
cache_depth
=> 0,
}
);
}
sub
getSession {
my
$id
=
shift
;
$id
=
$ENV
{LLNG_HASHED_SESSION_STORE} ? id2storage(
$id
) :
$id
;
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
),
}
);
}
sub
getSamlSession {
my
$id
=
shift
;
my
@sessionsOpts
= (
storageModule
=>
"Apache::Session::File"
,
storageModuleOptions
=> {
Directory
=>
"$tmpDir/saml"
,
LockDirectory
=>
"$tmpDir/saml/lock"
,
},
);
return
Lemonldap::NG::Common::Session->new( {
@sessionsOpts
,
id
=>
$id
,
}
);
}
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
{
is( getRedirection(
$res
),
$location
,
" Location is $location"
);
count(1);
}
}
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
;
}
sub
getJsVars {
local
$Test::Builder::Level
=
$Test::Builder::Level
+ 1;
my
(
$res
) =
@_
;
my
$initscripts
=
getHtmlElement(
$res
,
'//script[@type="application/init"]'
);
my
@parsed_initscripts
=
map
{ from_json(
$_
->string_value ) }
$initscripts
->get_nodelist();
my
%vars
=
map
{
%$_
}
@parsed_initscripts
;
return
\
%vars
;
}
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=
"(?:(?:https?://([^/]+))?(/.*?)?|(#))"
.+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);
}
my
%fields
=
(
$res
->[2]->[0] =~
m
%fields
= (
$res
->[2]->[0] =~
m
%fields
);
%fields
= (
$res
->[2]->[0] =~
m
%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
();
}
}
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);
}
sub
expectSessionAttributes {
local
$Test::Builder::Level
=
$Test::Builder::Level
+ 1;
my
(
$app
,
$id
,
%attributes
) =
@_
;
my
$res
= getSessionAttributes(
$app
,
$id
);
for
my
$attr
(
keys
%attributes
) {
is(
$res
->{
$attr
},
$attributes
{
$attr
},
"Session has correct value for $attr"
);
count(1);
}
}
sub
getSessionAttributes {
local
$Test::Builder::Level
=
$Test::Builder::Level
+ 1;
my
(
$app
,
$id
) =
@_
;
$id
=
$ENV
{LLNG_HASHED_SESSION_STORE} ? id2storage(
$id
) :
$id
;
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);
return
$res
;
}
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);
}
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
;
}
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);
}
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);
}
sub
expectPortalError {
local
$Test::Builder::Level
=
$Test::Builder::Level
+ 1;
my
(
$res
,
$errnum
,
$message
) =
@_
;
$errnum
||= 9;
$message
||=
"Expected portal error code"
;
my
(
$error
) =
$res
->[2]->[0] =~
qr/<span trmsg="(\d+)">/
;
ok(
$error
,
"$message: code found on page"
) or explain
$res
->[2]->[0];
is(
$error
,
$errnum
,
$message
);
count(2);
}
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);
}
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
;
}
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
;
}
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
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);
}
sub
getHtmlElement {
local
$Test::Builder::Level
=
$Test::Builder::Level
+ 1;
my
(
$res
,
$xpath
) =
@_
;
ok(
$res
->[2]->[0],
"Response body is not empty"
);
count(1);
my
$doc
=
XML::LibXML->new->load_html(
string
=>
$res
->[2]->[0],
recover
=> 2 );
return
$doc
->findnodes(
$xpath
);
}
sub
expectXpath {
local
$Test::Builder::Level
=
$Test::Builder::Level
+ 1;
my
(
$res
,
$xpath
,
$message
) =
@_
;
$message
||=
"Found at least one result for $xpath"
;
ok(
$res
= getHtmlElement(
$res
,
$xpath
),
$message
, );
count(1);
return
$res
;
}
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
;
}
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
;
}
sub
getRedirection {
my
(
$resp
) =
@_
;
return
getHeader(
$resp
,
'Location'
);
}
sub
getUser {
my
(
$resp
) =
@_
;
return
getHeader(
$resp
,
'Lm-Remote-User'
);
}
sub
tempdb {
return
"$tmpDir/userdb.db"
;
}
my
%handlerOR
;
my
%handlerTSHV
;
our
@currenthandler
;
sub
register {
local
$Test::Builder::Level
=
$Test::Builder::Level
+ 1;
my
(
$type
,
$constructor
) =
@_
;
my
$obj
;
@Lemonldap::NG::Handler::Main::_onReload
= ();
$Lemonldap::NG::Handler::Main::_tshv
= {
tsv
=> {},
cfgNum
=> 0,
cfgDate
=> 0,
lastCheck
=> 0,
checkTime
=> 600,
confAcc
=> {},
logger
=> {},
userLogger
=> {},
lmConf
=> {},
localConfig
=> {},
_auditLogger
=> {},
};
&Lemonldap::NG::Handler::Main::cfgNum
( 0, 0 );
@currenthandler
=
$type
;
ok(
$obj
=
$constructor
->(),
'Register $type'
);
if
(
$obj
and blessed(
$obj
) and
$obj
->can(
'app'
) ) {
my
$inner_app
=
$obj
->app;
my
$wrapper
=
sub
{
pushHandler(
$type
);
my
$res
=
$inner_app
->(
@_
);
popHandler();
return
$res
;
};
$obj
->app(
$wrapper
);
}
count(1);
$handlerOR
{
$type
} = [
@Lemonldap::NG::Handler::Main::_onReload
];
$handlerTSHV
{
$type
} =
$Lemonldap::NG::Handler::Main::_tshv
;
pop
@currenthandler
;
return
$obj
;
}
sub
withHandler {
my
(
$type
,
$sub
) =
@_
;
pushHandler(
$type
);
$sub
->();
popHandler();
}
sub
pushHandler {
my
$type
=
shift
;
if
(
@currenthandler
) {
my
$type
=
$currenthandler
[-1];
note(
'==> Saving handler '
.
uc
(
$type
) .
' <=='
);
$handlerOR
{
$type
} = [
@Lemonldap::NG::Handler::Main::_onReload
];
$handlerTSHV
{
$type
} =
$Lemonldap::NG::Handler::Main::_tshv
;
}
note(
'==> Pushing '
.
uc
(
$type
) .
' <=='
);
push
@currenthandler
,
$type
;
@Lemonldap::NG::Handler::Main::_onReload
= @{
$handlerOR
{
$type
};
};
$Lemonldap::NG::Handler::Main::_tshv
=
$handlerTSHV
{
$type
};
}
sub
popHandler {
my
$type
=
pop
@currenthandler
;
note(
'==> Popping '
.
uc
(
$type
) .
' <=='
);
if
(
@currenthandler
) {
my
$type
=
$currenthandler
[-1];
return
[]
unless
$handlerOR
{
$type
};
note(
'==> Restoring '
.
uc
(
$type
) .
' <=='
);
@Lemonldap::NG::Handler::Main::_onReload
= @{
$handlerOR
{
$type
};
};
$Lemonldap::NG::Handler::Main::_tshv
=
$handlerTSHV
{
$type
};
}
}
sub
switch {
note shortmess(
'Manual switching is deprecated,'
.
' you can remove it from your tests'
);
}
sub
encodeUrl {
my
(
$url
) =
@_
;
return
encode_base64(
$url
,
''
);
}
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'
,
languages
=>
'en, fr'
,
domain
=>
'example.com'
,
templateDir
=>
$templateDir
,
staticPrefix
=>
'/static'
,
tokenUseGlobalStorage
=> 0,
securedCookie
=> 0,
(
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'
,
},
};
has
app
=> (
is
=>
'rw'
,
isa
=>
'CodeRef'
,
);
has
class
=> (
is
=>
'ro'
,
default
=>
'Lemonldap::NG::Portal::Main'
);
has
p
=> (
is
=>
'rw'
);
has
accept
=> (
is
=>
'rw'
,
default
=>
'application/json, text/plain, */*'
);
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
};
}
if
(
$ENV
{DEBUG} ) {
$ini
->{logLevel} =
'debug'
;
$ini
->{logger} =
"t::TestStdLogger"
;
}
if
(
$ENV
{LLNGLOGLEVEL} ) {
$ini
->{logLevel} =
$ENV
{LLNGLOGLEVEL};
$ini
->{logger} =
"t::TestStdLogger"
;
}
$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
;
}
);
sub
login {
local
$Test::Builder::Level
=
$Test::Builder::Level
+ 1;
my
(
$self
,
$uid
,
$getParams
) =
@_
;
my
$res
;
$getParams
||= {};
my
$query
= main::buildForm( {
user
=>
$uid
,
password
=>
$uid
,
%$getParams
,
}
);
main::ok(
$res
=
$self
->_post(
'/'
,
IO::String->new(
$query
),
length
=>
length
(
$query
),
),
'Auth query'
);
main::count(1);
main::expectOK(
$res
);
my
$id
= main::expectCookie(
$res
);
return
$id
;
}
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);
}
sub
_get {
my
(
$self
,
$path
,
%args
) =
@_
;
if
(
ref
(
$args
{query} ) eq
"HASH"
) {
$args
{query} = main::buildForm(
$args
{query} );
}
my
$res
=
$self
->app->( {
'HTTP_ACCEPT'
=>
$args
{
accept
} //
$self
->
accept
,
'HTTP_ACCEPT_LANGUAGE'
=>
'en-US,fr-FR;q=0.7,fr;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
;
}
sub
_post {
my
(
$self
,
$path
,
$body
,
%args
) =
@_
;
if
(
ref
(
$body
) eq
"HASH"
) {
$body
= main::buildForm(
$body
);
}
unless
(
ref
(
$body
) ) {
$args
{
length
} =
length
(
$body
);
$body
= IO::String->new(
"$body"
);
}
die
"$body must be a IO::Handle"
unless
(
ref
(
$body
) and
$body
->can(
'read'
) );
my
$res
=
$self
->app->( {
'HTTP_ACCEPT'
=>
$args
{
accept
} //
$self
->
accept
,
'HTTP_ACCEPT_LANGUAGE'
=>
'en-US,fr-FR;q=0.7,fr;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
},
'CONTENT_TYPE'
=>
$args
{type}
||
'application/x-www-form-urlencoded'
,
}
);
return
$res
;
}
sub
_delete {
my
(
$self
,
$path
,
%args
) =
@_
;
$args
{method} =
'DELETE'
;
$self
->_get(
$path
,
%args
);
}
sub
_options {
my
(
$self
,
$path
,
%args
) =
@_
;
$args
{method} =
'OPTIONS'
;
$self
->_get(
$path
,
%args
);
}
sub
_put {
my
(
$self
,
$path
,
$body
,
%args
) =
@_
;
$args
{method} =
'PUT'
;
return
$self
->_post(
$path
,
$body
,
%args
);
}
sub
getHistory {
my
(
$self
,
$uid
,
$only_type
) =
@_
;
my
$psession
=
$self
->p->getPersistentSession(
$uid
);
my
@entries
;
my
$history
=
$psession
->data->{_loginHistory} || {};
for
my
$type
(
keys
%$history
) {
if
( !
$only_type
or
$type
eq
"${only_type}Login"
) {
push
@entries
, @{
$history
->{
$type
} || [] };
}
}
return
@entries
;
}
1;