our
$VERSION
=
'2.0.15'
;
has
ua
=> (
is
=>
'rw'
,
lazy
=> 1,
builder
=>
sub
{
my
$ua
= Lemonldap::NG::Common::UserAgent->new(
$_
[0]->{conf} );
$ua
->env_proxy();
return
$ua
;
}
);
has
casSrvList
=> (
is
=>
'rw'
,
default
=>
sub
{ {} }, );
has
casAppList
=> (
is
=>
'rw'
,
default
=>
sub
{ {} }, );
has
srvRules
=> (
is
=>
'rw'
,
default
=>
sub
{ {} }, );
has
spRules
=> (
is
=>
'rw'
,
default
=>
sub
{ {} }, );
has
spMacros
=> (
is
=>
'rw'
,
default
=>
sub
{ {} }, );
sub
loadSrv {
my
(
$self
) =
@_
;
unless
(
$self
->conf->{casSrvMetaDataOptions}
and %{
$self
->conf->{casSrvMetaDataOptions} } )
{
$self
->logger->error(
"No CAS servers found in configuration"
);
return
0;
}
$self
->casSrvList(
$self
->conf->{casSrvMetaDataOptions} );
foreach
(
keys
%{
$self
->conf->{casSrvMetaDataOptions} } ) {
my
$cond
=
$self
->conf->{casSrvMetaDataOptions}->{
$_
}
->{casSrvMetaDataOptionsResolutionRule};
if
(
length
$cond
) {
my
$rule_sub
=
$self
->p->buildRule(
$cond
,
"CAS server resolution"
);
if
(
$rule_sub
) {
$self
->srvRules->{
$_
} =
$rule_sub
;
}
}
}
return
1;
}
sub
loadApp {
my
(
$self
) =
@_
;
unless
(
$self
->conf->{casAppMetaDataOptions}
and %{
$self
->conf->{casAppMetaDataOptions} } )
{
$self
->logger->info(
"No CAS apps found in configuration"
);
}
foreach
(
keys
%{
$self
->conf->{casAppMetaDataOptions} } ) {
my
$valid
= 1;
my
$rule
=
$self
->conf->{casAppMetaDataOptions}->{
$_
}
->{casAppMetaDataOptionsRule};
if
(
length
$rule
) {
$rule
=
$self
->p->HANDLER->substitute(
$rule
);
unless
(
$rule
=
$self
->p->HANDLER->buildSub(
$rule
) ) {
$self
->logger->error(
"Unable to build access rule for CAS Application $_: "
.
$self
->p->HANDLER->tsv->{jail}->error );
$valid
= 0;
}
}
my
$macros
=
$self
->conf->{casAppMetaDataMacros}->{
$_
};
my
$compiledMacros
= {};
for
my
$macroAttr
(
keys
%{
$macros
} ) {
my
$macroRule
=
$macros
->{
$macroAttr
};
if
(
length
$macroRule
) {
$macroRule
=
$self
->p->HANDLER->substitute(
$macroRule
);
if
(
$macroRule
=
$self
->p->HANDLER->buildSub(
$macroRule
) ) {
$compiledMacros
->{
$macroAttr
} =
$macroRule
;
}
else
{
$self
->logger->error(
"Unable to build macro $macroAttr for CAS Application $_: "
.
$self
->p->HANDLER->tsv->{jail}->error );
$valid
= 0;
}
}
}
if
(
$valid
) {
$self
->casAppList->{
$_
} =
$self
->conf->{casAppMetaDataOptions}->{
$_
};
$self
->spRules->{
$_
} =
$rule
;
$self
->spMacros->{
$_
} =
$compiledMacros
;
}
else
{
$self
->logger->error(
"CAS Application $_ has errors and will be ignored"
);
}
}
return
1;
}
sub
sendSoapResponse {
my
(
$self
,
$req
,
$s
) =
@_
;
$self
->logger->debug(
"Send response: $s"
);
return
[
200,
[
'Content-Length'
=>
length
(
$s
),
'Content-Type'
=>
'application/soap+xml'
,
],
[
$s
]
];
}
sub
getCasSession {
my
(
$self
,
$id
,
$info
) =
@_
;
my
%storage
= (
storageModule
=>
$self
->conf->{casStorage},
storageModuleOptions
=>
$self
->conf->{casStorageOptions},
);
unless
(
$storage
{storageModule} ) {
%storage
= (
storageModule
=>
$self
->conf->{globalStorage},
storageModuleOptions
=>
$self
->conf->{globalStorageOptions},
);
}
my
$casSession
= Lemonldap::NG::Common::Session->new( {
%storage
,
cacheModule
=>
$self
->conf->{localSessionStorage},
cacheModuleOptions
=>
$self
->conf->{localSessionStorageOptions},
id
=>
$id
,
kind
=>
$self
->sessionKind,
(
$info
? (
info
=>
$info
) : () ),
}
);
if
(
$casSession
->error ) {
if
(
$id
) {
$self
->userLogger->notice(
"CAS session $id isn't yet available"
);
}
else
{
$self
->logger->error(
"Unable to create new CAS session"
);
$self
->logger->error(
$casSession
->error );
}
return
undef
;
}
return
$casSession
;
}
sub
returnCasValidateError {
my
(
$self
,
$req
) =
@_
;
$self
->logger->debug(
"Return CAS validate error"
);
return
[ 200, [
'Content-Length'
=> 4 ], [
"no\n\n"
] ];
}
sub
returnCasValidateSuccess {
my
(
$self
,
$req
,
$username
) =
@_
;
$self
->logger->debug(
"Return CAS validate success with username $username"
);
return
$self
->sendSoapResponse(
$req
,
"yes\n$username\n"
);
}
sub
returnCasServiceValidateError {
my
(
$self
,
$req
,
$code
,
$text
) =
@_
;
$code
||=
'INTERNAL_ERROR'
;
$text
||=
'No description provided'
;
$self
->logger->debug(
"Return CAS service validate error $code ($text)"
);
return
$self
->sendSoapResponse(
\t<cas:authenticationFailure code=\"
$code
\">
\t\t
$text
\t</cas:authenticationFailure>
</cas:serviceResponse>\n"
);
}
sub
returnCasServiceValidateSuccess {
my
(
$self
,
$req
,
$username
,
$pgtIou
,
$proxies
,
$attributes
) =
@_
;
$self
->logger->debug(
"Return CAS service validate success with username $username"
);
\t<cas:authenticationSuccess>
\t\t<cas:user>
$username
</cas:user>\n";
if
(
defined
$attributes
) {
$s
.=
"\t\t<cas:attributes>\n"
;
foreach
my
$attribute
(
keys
%$attributes
) {
foreach
my
$value
(
split
(
$self
->conf->{multiValuesSeparator},
$attributes
->{
$attribute
}
)
)
{
$s
.=
"\t\t\t<cas:$attribute>$value</cas:$attribute>\n"
;
}
}
$s
.=
"\t\t</cas:attributes>\n"
;
}
if
(
defined
$pgtIou
) {
$self
->logger->debug(
"Add proxy granting ticket $pgtIou in response"
);
$s
.=
"\t\t<cas:proxyGrantingTicket>$pgtIou</cas:proxyGrantingTicket>\n"
;
}
if
(
$proxies
) {
$self
->logger->debug(
"Add proxies $proxies in response"
);
$s
.=
"\t\t<cas:proxies>\n"
;
$s
.=
"\t\t\t<cas:proxy>$_</cas:proxy>\n"
foreach
(
reverse
(
split
(
$self
->conf->{multiValuesSeparator},
$proxies
) ) );
$s
.=
"\t\t</cas:proxies>\n"
;
}
$s
.=
"\t</cas:authenticationSuccess>\n</cas:serviceResponse>\n"
;
return
$self
->sendSoapResponse(
$req
,
$s
);
}
sub
returnCasProxyError {
my
(
$self
,
$req
,
$code
,
$text
) =
@_
;
$code
||=
'INTERNAL_ERROR'
;
$text
||=
'No description provided'
;
$self
->logger->debug(
"Return CAS proxy error $code ($text)"
);
return
$self
->sendSoapResponse(
\t<cas:proxyFailure code=\"
$code
\">
\t\t
$text
\t</cas:proxyFailure>
</cas:serviceResponse>\n"
);
}
sub
returnCasProxySuccess {
my
(
$self
,
$req
,
$ticket
) =
@_
;
$self
->logger->debug(
"Return CAS proxy success with ticket $ticket"
);
return
$self
->sendSoapResponse(
\t<cas:proxySuccess>
\t\t<cas:proxyTicket>
$ticket
</cas:proxyTicket>
\t</cas:proxySuccess>
</cas:serviceResponse>\n"
);
}
sub
deleteCasSecondarySessions {
my
(
$self
,
$session_id
) =
@_
;
my
$result
= 1;
my
$moduleOptions
;
if
(
$self
->conf->{casStorage} ) {
$moduleOptions
=
$self
->conf->{casStorageOptions} || {};
$moduleOptions
->{backend} =
$self
->conf->{casStorage};
}
else
{
$moduleOptions
=
$self
->conf->{globalStorageOptions} || {};
$moduleOptions
->{backend} =
$self
->conf->{globalStorage};
}
my
$module
=
"Lemonldap::NG::Common::Apache::Session"
;
my
$cas_sessions
=
$module
->searchOn(
$moduleOptions
,
"_cas_id"
,
$session_id
);
if
(
my
@cas_sessions_keys
=
grep
{
$cas_sessions
->{
$_
}->{_session_kind} eq
$self
->sessionKind }
keys
%$cas_sessions
)
{
foreach
my
$cas_session
(
@cas_sessions_keys
) {
$self
->logger->debug(
"Retrieve CAS session $cas_session"
);
my
$casSession
=
$self
->getCasSession(
$cas_session
);
$result
=
$self
->deleteCasSession(
$casSession
);
}
}
else
{
$self
->logger->debug(
"No CAS session found for session $session_id "
);
}
return
$result
;
}
sub
deleteCasSession {
my
(
$self
,
$session
) =
@_
;
unless
(
$session
&&
$session
->data ) {
$self
->logger->error(
"No session to delete"
);
return
0;
}
my
$session_id
=
$session
->id;
unless
(
$session
->remove ) {
$self
->logger->error(
$session
->error );
return
0;
}
$self
->logger->debug(
"CAS session $session_id deleted"
);
return
1;
}
sub
callPgtUrl {
my
(
$self
,
$pgtUrl
,
$pgtIou
,
$pgtId
) =
@_
;
my
$url
=
$pgtUrl
. (
$pgtUrl
=~ /\?/ ?
'&'
:
'?'
)
. build_urlencoded(
pgtIou
=>
$pgtIou
,
pgtId
=>
$pgtId
);
$self
->logger->debug(
"Call URL $url"
);
my
$response
=
$self
->ua->get(
$url
);
return
$response
->is_success();
}
sub
getServerLoginURL {
my
(
$self
,
$service
,
$srvConf
) =
@_
;
return
"$srvConf->{casSrvMetaDataOptionsUrl}/login?"
. build_urlencoded(
service
=>
$service
);
}
sub
getServerLogoutURL {
my
(
$self
,
$service
,
$srvUrl
) =
@_
;
return
"$srvUrl/logout?"
. build_urlencoded(
service
=>
$service
);
}
sub
validateST {
my
(
$self
,
$req
,
$service
,
$ticket
,
$srvConf
,
$proxied
) =
@_
;
my
%prm
= (
service
=>
$service
,
ticket
=>
$ticket
);
my
$proxy_url
;
if
(
%$proxied
) {
$proxy_url
=
$self
->p->fullUrl(
$req
);
die
if
(
$proxy_url
=~ /casProxy=1/ );
$proxy_url
.= (
$proxy_url
=~ /\?/ ?
'&'
:
'?'
) .
'casProxy=1'
;
$self
->logger->debug(
"CAS Proxy URL: $proxy_url"
);
$req
->data->{casProxyUrl} =
$proxy_url
;
$prm
{pgtUrl} =
$proxy_url
;
}
my
$serviceValidateUrl
=
"$srvConf->{casSrvMetaDataOptionsUrl}/serviceValidate?"
. build_urlencoded(
%prm
);
$self
->logger->debug(
"Validate ST on CAS URL $serviceValidateUrl"
);
my
$response
=
$self
->ua->get(
$serviceValidateUrl
);
$self
->logger->debug(
"Get CAS serviceValidate response: "
.
$response
->as_string );
return
0
if
$response
->is_error;
my
$xml
=
$response
->decoded_content(
default_charset
=>
'UTF-8'
);
utf8::encode(
$xml
);
$xml
= XMLin(
$xml
);
if
(
defined
$xml
->{
'cas:authenticationFailure'
} ) {
$self
->logger->error(
"Failed to validate Service Ticket $ticket: "
.
$xml
->{
'cas:authenticationFailure'
}->{content} );
return
0;
}
if
(
$proxy_url
) {
my
$pgtIou
=
$xml
->{
'cas:authenticationSuccess'
}->{
'cas:proxyGrantingTicket'
};
if
(
$pgtIou
) {
my
$moduleOptions
;
if
(
$self
->conf->{casStorage} ) {
$moduleOptions
=
$self
->conf->{casStorageOptions} || {};
$moduleOptions
->{backend} =
$self
->conf->{casStorage};
}
else
{
$moduleOptions
=
$self
->conf->{globalStorageOptions} || {};
$moduleOptions
->{backend} =
$self
->conf->{globalStorage};
}
my
$module
=
"Lemonldap::NG::Common::Apache::Session"
;
my
$pgtIdSessions
=
$module
->searchOn(
$moduleOptions
,
"pgtIou"
,
$pgtIou
);
foreach
my
$id
(
grep
{
$pgtIdSessions
->{
$_
}->{_session_kind} eq
$self
->sessionKind
}
keys
%$pgtIdSessions
)
{
my
$pgtIdSession
=
$self
->getCasSession(
$id
) or
next
;
$req
->data->{pgtId} =
$pgtIdSession
->data->{pgtId};
$pgtIdSession
->remove;
}
}
}
my
$user
=
$xml
->{
'cas:authenticationSuccess'
}->{
'cas:user'
};
my
$attrs
= {};
if
(
my
$casAttr
=
$xml
->{
'cas:authenticationSuccess'
}->{
'cas:attributes'
} )
{
foreach
my
$k
(
keys
%$casAttr
) {
my
$v
=
$casAttr
->{
$k
};
if
(
ref
(
$v
) eq
"ARRAY"
) {
$v
=
join
(
$self
->conf->{multiValuesSeparator},
@$v
);
}
utf8::encode(
$v
);
$attrs
->{
$k
} =
$v
;
}
}
return
(
$user
,
$attrs
);
}
sub
storePGT {
my
(
$self
,
$pgtIou
,
$pgtId
) =
@_
;
my
$infos
= {
type
=>
'casPgtId'
,
_utime
=>
time
,
pgtIou
=>
$pgtIou
,
pgtId
=>
$pgtId
};
my
$pgtSession
=
$self
->getCasSession(
undef
,
$infos
);
return
$pgtSession
->id;
}
sub
retrievePT {
my
(
$self
,
$service
,
$pgtId
,
$srvConf
) =
@_
;
my
$proxyUrl
=
"$srvConf->{casSrvMetaDataOptionsUrl}/proxy?"
. build_urlencoded(
targetService
=>
$service
,
pgt
=>
$pgtId
);
my
$response
=
$self
->ua->get(
$proxyUrl
);
$self
->logger->debug(
"Get CAS proxy response: "
.
$response
->as_string );
return
0
if
$response
->is_error;
my
$xml
= XMLin(
$response
->decoded_content );
if
(
defined
$xml
->{
'cas:proxyFailure'
} ) {
$self
->logger->error(
"Failed to get PT: "
.
$xml
->{
'cas:proxyFailure'
} );
return
0;
}
my
$pt
=
$xml
->{
'cas:proxySuccess'
}->{
'cas:proxyTicket'
};
return
$pt
;
}
sub
getCasApp {
my
(
$self
,
$uri_param
) =
@_
;
my
$uri
= URI->new(
$uri_param
);
my
$hostname
=
$uri
->authority;
my
$uriCanon
=
$uri
->canonical;
return
undef
unless
$hostname
;
my
$prefixConfKey
;
my
$longestCandidate
=
""
;
my
$hostnameConfKey
;
for
my
$app
(
keys
%{
$self
->casAppList } ) {
for
my
$appservice
(
split
(
/\s+/,
$self
->casAppList->{
$app
}->{casAppMetaDataOptionsService}
)
)
{
my
$candidateUri
= URI->new(
$appservice
);
my
$candidateHost
=
$candidateUri
->authority;
my
$candidateCanon
=
$candidateUri
->canonical;
if
(
index
(
$uriCanon
,
$candidateCanon
) == 0 ) {
if
(
length
(
$longestCandidate
) <
length
(
$candidateCanon
) ) {
$longestCandidate
=
$candidateCanon
;
$prefixConfKey
=
$app
;
}
}
unless
(
$self
->conf->{casStrictMatching} ) {
$hostnameConfKey
=
$app
if
(
$hostname
eq
$candidateHost
);
}
}
}
return
$prefixConfKey
if
$prefixConfKey
;
$self
->logger->
warn
(
"Matched CAS service $hostnameConfKey based on hostname only. "
.
"This will be deprecated in a future version"
)
if
$hostnameConfKey
;
return
$hostnameConfKey
;
}
sub
_getHostForService {
my
(
$self
,
$service
) =
@_
;
return
undef
unless
$service
;
my
$uri
= URI->new(
$service
);
return
$uri
->scheme ?
$uri
->host :
$uri
->as_string;
}
1;