our
$VERSION
=
'1.0.0'
;
our
(
$stylesheet
,
$parser
);
sub
confUpload {
my
(
$self
,
$rdata
) =
@_
;
$$rdata
=~ s/<img.*?>//g;
$$rdata
=~ s/<li class=
"line"
.*?<\/li>//g;
my
$vhostname
;
my
$idpname
;
my
$spname
;
my
$catid
;
my
$postname
;
my
$result
=
$self
->stylesheet->transform(
$self
->parser->parse_string(
'<root>'
.
$$rdata
.
'</root>'
) )
->documentElement();
unless
(
$self
->{cfgNum} =
$result
->getChildrenByTagName(
'conf'
)->[0]->getAttribute(
'value'
) )
{
die
"No configuration number found"
;
}
my
$newConf
= {
cfgNum
=>
$self
->{cfgNum} };
my
$errors
= {};
foreach
( @{
$result
->getChildrenByTagName(
'element'
) } ) {
my
(
$id
,
$name
,
$value
) = (
$_
->getAttribute(
'id'
),
$_
->getAttribute(
'name'
),
$_
->getAttribute(
'value'
)
);
my
$catflag
= 0;
my
$appflag
= 0;
my
$postflag
= 0;
my
$postdataflag
= 0;
$value
= uri_unescape(
$value
);
$self
->lmLog(
"Upload process for attribute $name (id: $id / value: $value)"
,
'debug'
);
my
$NK
= 0;
$id
=~
s/^text_(NewID_)?li_([\w\/\+\=]+)(\d)(?:_\d+)?$/decode_base64($2.
'='
x $3)/e;
$NK
= 1
if
($1);
$id
=~ s/\r//g;
$id
=~ s/^\///;
$self
->lmLog(
"id decoded into $id"
,
'debug'
);
if
(
$id
=~ /locationRules\/([^\/]*)?$/ ) {
$self
->lmLog(
"Entering Virtual Host $name"
,
'debug'
);
$vhostname
=
$name
;
}
if
(
$id
=~ /samlIDPMetaDataExportedAttributes\/([^\/]*)?$/ ) {
$self
->lmLog(
"Entering IDP $name"
,
'debug'
);
$idpname
=
$name
;
}
if
(
$id
=~ /samlSPMetaDataExportedAttributes\/([^\/]*)?$/ ) {
$self
->lmLog(
"Entering SP $name"
,
'debug'
);
$spname
=
$name
;
}
if
(
$id
=~ /applicationList/ ) {
if
(
$value
=~ /^(.*)?\|(.*)?\|(.*)?\|(.*)?\|(.*?)$/ ) {
$self
->lmLog(
"Entering application $name"
,
'debug'
);
$appflag
= 1;
}
else
{
$self
->lmLog(
"Entering category $name"
,
'debug'
);
$catid
=
$name
;
$catflag
= 1;
}
}
if
(
$id
=~ /post\/([^\/]*)?\/.*$/ ) {
$self
->lmLog(
"POST data $name"
,
'debug'
);
$postdataflag
= 1;
}
else
{
$self
->lmLog(
"Entering POST URL $name"
,
'debug'
);
$postflag
= 1;
$postname
=
$name
;
}
}
if
(
$NK
) {
$id
=~ s/5$//;
if
(
$id
=~
/^(virtualHosts|samlIDPMetaDataExportedAttributes|samlSPMetaDataExportedAttributes|generalParameters\/authParams\/choiceParams)/
)
{
$self
->lmLog(
"Special trigger for $id (attribute $name)"
,
'debug'
);
$id
=~
s/^virtualHosts\/([^\/]*)?\/header.*/exportedHeaders\/$1\/
$name
/;
$id
=~
s/^virtualHosts\/([^\/]*)?\/rule.*/locationRules\/$1\/
$name
/;
$id
=~ s/^virtualHosts\/([^\/]*)?\/post.*/post\/$1\/
$name
/;
$id
=~
s/^samlIDPMetaDataExportedAttributes\/([^\/]*)?.*/samlIDPMetaDataExportedAttributes\/$1\/
$name
/;
$id
=~
s/^samlSPMetaDataExportedAttributes\/([^\/]*)?.*/samlSPMetaDataExportedAttributes\/$1\/
$name
/;
$id
=~
s/^generalParameters\/authParams\/choiceParams\/([^\/]*)?.*/authChoiceModules\/
$name
/;
}
elsif
(
$id
=~ /applicationList/ ) {
$id
=
"applicationList"
; }
else
{
$id
=~ s/(?:\/[^\/]*)?$/\/
$name
/;
}
}
$id
=~
s/^(exportedHeaders|locationRules|post)\/([^\/]*)?\/(.*)$/$1\/
$vhostname
\/$3/;
$id
=~
s/^(samlIDPMetaDataXML|samlIDPMetaDataExportedAttributes|samlIDPMetaDataOptions)\/([^\/]*)?\/(.*)$/$1\/
$idpname
\/$3/;
$id
=~
s/^(samlSPMetaDataXML|samlSPMetaDataExportedAttributes|samlSPMetaDataOptions)\/([^\/]*)?\/(.*)$/$1\/
$spname
\/$3/;
$id
=~ s/^(post)\/([^\/]*)?\/(.*)$/$1\/
$vhostname
\/
$postname
/;
$self
->lmLog(
"id transformed into $id"
,
'debug'
);
if
(
$id
=~
/^(generalParameters|variables|virtualHosts|samlIDPMetaDataNode|samlSPMetaDataNode)/
)
{
$self
->lmLog(
"Ignoring attribute $name (id $id)"
,
'debug'
);
next
;
}
my
(
$confKey
,
$test
) =
$self
->getConfTests(
$id
);
my
(
$res
,
$m
);
if
( !
defined
(
$test
) ) {
$self
->lmLog(
"No test defined for key $id (name: $name, value: $value)"
,
'warn'
);
$test
= {
test
=>
sub
{ 1 },
msgFail
=>
'Ok'
};
}
if
(
$test
->{
'*'
} and
$id
=~ /\// ) {
$test
=
$test
->{
'*'
} }
unless
(
$test
->{keyTest} and (
$id
!~ /\// or
$test
->{
'*'
} ) ) {
if
(
$test
->{keyTest} ) {
(
$res
,
$m
) =
$self
->applyTest(
$test
->{keyTest},
$name
);
unless
(
$res
) {
$errors
->{errors}->{
$name
} =
$m
||
$test
->{keyMsgFail};
next
;
}
$errors
->{warnings}->{
$name
} =
$m
if
(
$m
);
}
if
(
$test
->{test} ) {
(
$res
,
$m
) =
$self
->applyTest(
$test
->{test},
$value
);
unless
(
$res
) {
$errors
->{errors}->{
$name
} =
$m
||
$test
->{msgFail};
next
;
}
$errors
->{warnings}->{
$name
} =
$m
if
(
$m
);
}
if
(
$test
->{warnKeyTest} ) {
(
$res
,
$m
) =
$self
->applyTest(
$test
->{warnKeyTest},
$name
);
unless
(
$res
) {
$errors
->{warnings}->{
$name
} =
$m
||
$test
->{keyMsgWarn};
}
}
if
(
$test
->{warnTest} ) {
(
$res
,
$m
) =
$self
->applyTest(
$test
->{warnTest},
$value
);
unless
(
$res
) {
$errors
->{warnings}->{
$name
} =
$m
||
$test
->{keyMsgWarn};
}
}
}
if
(
$catflag
) {
$self
->lmLog(
"Register category $name data"
,
'debug'
);
$self
->setKeyToH(
$newConf
,
"applicationList/$name/catname"
,
$value
);
$self
->setKeyToH(
$newConf
,
"applicationList/$name/type"
,
"category"
);
}
elsif
(
$appflag
) {
$self
->lmLog(
"Register application $name data"
,
'debug'
);
my
@t
=
split
( /\|/,
$value
);
$self
->setKeyToH(
$newConf
,
"applicationList/$catid/$name/options/name"
,
$t
[0] );
$self
->setKeyToH(
$newConf
,
"applicationList/$catid/$name/options/uri"
,
$t
[1] );
$self
->setKeyToH(
$newConf
,
"applicationList/$catid/$name/options/description"
,
$t
[2] );
$self
->setKeyToH(
$newConf
,
"applicationList/$catid/$name/options/logo"
,
$t
[3] );
$self
->setKeyToH(
$newConf
,
"applicationList/$catid/$name/options/display"
,
$t
[4] );
$self
->setKeyToH(
$newConf
,
"applicationList/$catid/$name/type"
,
"application"
);
}
elsif
(
$postflag
) {
$self
->lmLog(
"Register POST URL $name data"
,
'debug'
);
$self
->setKeyToH(
$newConf
,
"post/$vhostname"
,
"$postname"
, {
postUrl
=>
$value
}
)
if
$value
;
}
elsif
(
$postdataflag
) {
$self
->lmLog(
"Register POST data $name"
,
'debug'
);
$self
->setKeyToH(
$newConf
,
"post/$vhostname"
,
"$postname"
,
{
expr
=> {
$name
=>
$value
} } )
if
$value
;
}
else
{
$self
->setKeyToH(
$newConf
,
$confKey
,
$test
->{keyTest}
? ( (
$id
!~ /\// or
$test
->{
'*'
} ) ? {} : (
$name
=>
$value
) )
:
$value
);
}
}
$self
->lmLog(
"Restore unchanged parameters"
,
'debug'
);
foreach
( @{
$result
->getChildrenByTagName(
'ignore'
) } ) {
my
$node
=
$_
->getAttribute(
'value'
);
$node
=~ s/^.
*node
=(.*?)(?:&.*)?\}$/$1/;
$self
->lmLog(
"Unchanged node $node"
,
'debug'
);
foreach
my
$k
(
$self
->findAllConfKeys(
$self
->corresp(
$node
) ) ) {
$self
->lmLog(
"Unchanged key $k (node $node)"
,
'debug'
);
my
$v
=
$self
->keyToH(
$k
,
$self
->conf );
$v
=
$self
->keyToH(
$k
,
$self
->defaultConf )
unless
(
defined
$v
);
if
(
defined
$v
) {
$self
->setKeyToH(
$newConf
,
$k
,
$v
);
}
else
{
$self
->lmLog(
"No default value found for $k"
,
'info'
);
}
}
}
$newConf
->{cfgAuthor} =
$ENV
{REMOTE_USER} ||
'anonymous'
;
$newConf
->{cfgAuthorIP} =
$ENV
{REMOTE_ADDR};
$newConf
->{cfgDate} =
time
();
$self
->lmLog(
"Launch global tests"
,
'debug'
);
{
my
$tests
=
$self
->globalTests(
$newConf
);
while
(
my
(
$name
,
$sub
) =
each
%$tests
) {
my
(
$res
,
$msg
);
eval
{
(
$res
,
$msg
) =
$sub
->();
if
(
$res
== -1 ) {
$errors
->{force}->{
$name
} =
$msg
unless
(
$self
->param(
'force'
) );
}
elsif
(
$res
) {
if
(
$msg
) {
$errors
->{warnings}->{
$name
} =
$msg
;
}
}
else
{
$errors
->{errors}->{
$name
} =
$msg
;
}
};
$errors
->{warnings}->{
$name
} =
"Test $name failed: $@"
if
($@);
}
}
$errors
->{result}->{other} =
''
;
if
(
$errors
->{errors} ) {
$errors
->{result}->{cfgNum} = 0;
$errors
->{result}->{msg} =
$self
->translate(
'syntaxError'
);
$self
->_sub(
'userInfo'
,
"Configuration rejected for $newConf->{cfgAuthor}: syntax error"
);
}
elsif
(
$errors
->{force} ) {
$errors
->{result}->{cfgNum} = 0;
$errors
->{result}->{msg} =
$self
->translate(
'warning'
);
$self
->_sub(
'userInfo'
,
"Configuration rejected for $newConf->{cfgAuthor}: confirmation needed"
);
$errors
->{result}->{other} =
'*<a href="javascript:uploadConf(1)">'
.
$self
->translate(
'clickHereToForce'
) .
'</a>'
;
foreach
my
$k
(
keys
%{
$errors
->{force} } ) {
$errors
->{errors}->{
$k
} =
delete
(
$errors
->{force}->{
$k
} ) .
'<sup>*</sup>'
;
}
}
else
{
$self
->confObj->{force} = 1
if
(
$self
->param(
'force'
) );
$errors
->{result}->{cfgNum} =
$self
->confObj->saveConf(
$newConf
);
my
$msg
;
if
(
$errors
->{result}->{cfgNum} > 0 ) {
$errors
->{cfgDatas} = {
cfgAuthor
=>
$newConf
->{cfgAuthor},
cfgAuthorIP
=>
$newConf
->{cfgAuthorIP},
cfgDate
=>
$newConf
->{cfgDate}
};
$msg
=
'confSaved'
;
$self
->_sub(
'userNotice'
,
"Conf $errors->{result}->{cfgNum} saved by $newConf->{cfgAuthor}"
);
$errors
->{applyStatus} =
$self
->applyConf();
}
else
{
$msg
= {
CONFIG_WAS_CHANGED,
'confWasChanged'
,
UNKNOWN_ERROR,
'unknownError'
,
DATABASE_LOCKED,
'databaseLocked'
,
UPLOAD_DENIED,
'uploadDenied'
,
SYNTAX_ERROR,
'syntaxError'
,
DEPRECATED,
'confModuledeprecated'
,
}->{
$errors
->{result}->{cfgNum} }
||
$msg
;
$self
->_sub(
'userError'
,
"Configuration rejected for $newConf->{cfgAuthor}: $msg"
);
}
$errors
->{result}->{msg} =
$self
->translate(
$msg
);
if
(
$errors
->{result}->{cfgNum} == CONFIG_WAS_CHANGED
or
$errors
->{result}->{cfgNum} == DATABASE_LOCKED )
{
$errors
->{result}->{other} =
'<a href="javascript:uploadConf(1)">'
.
$self
->translate(
'clickHereToForce'
) .
'</a>'
;
}
elsif
(
$errors
->{result}->{cfgNum} == DEPRECATED ) {
$errors
->{result}->{other} =
'Module : '
.
$self
->confObj->{type};
}
}
my
$buf
=
'{'
;
my
$i
= 0;
while
(
my
(
$type
,
$h
) =
each
%$errors
) {
$buf
.=
','
if
(
$i
);
$buf
.=
"\"$type\":{"
;
$buf
.=
join
(
','
,
map
{
$h
->{
$_
} =~ s/
"/\\"
/g;
$h
->{
$_
} =~ s/\n/ /g;
"\"$_\":\"$h->{$_}\""
}
keys
%$h
);
$buf
.=
'}'
;
$i
++;
}
$buf
.=
'}'
;
binmode
( STDOUT,
':bytes'
);
utf8::encode(
$buf
);
print
$self
->header(
-type
=>
'application/json; charset=utf-8'
,
-Content_Length
=>
length
(
$buf
)
);
print
$buf
;
$self
->quit();
}
sub
fileUpload {
my
$self
=
shift
;
my
$fieldname
=
shift
;
my
$filename
=
shift
;
my
$content
=
''
;
if
(
$filename
) {
$content
= ${
$self
->rparam(
$fieldname
) };
print
$self
->header(
-type
=>
'application/force-download; charset=utf-8'
,
-attachment
=>
$filename
,
-Content_Length
=>
length
$content
) .
$content
;
}
else
{
my
$UPLOAD_FH
=
$self
->upload(
$fieldname
);
while
(<
$UPLOAD_FH
>) {
$content
.=
"$_"
;
}
$content
=~ s!<!
<
;!g;
$content
=~ s!>!
>
;!g;
my
$json
= new JSON();
my
$json_content
=
''
;
if
(
$JSON::VERSION
lt 2 ) {
local
$JSON::UTF8
= 1;
$json_content
=
$json
->objToJson( [
$content
] );
$json_content
=~ s/^\[//;
$json_content
=~ s/\]$//;
}
else
{
$json
=
$json
->allow_nonref( [
'1'
] );
$json
=
$json
->utf8( [
'1'
] );
$json_content
=
$json
->encode(
$content
);
}
my
$content
=
'{"status":"OK", "content":'
.
$json_content
.
'}'
;
print
$self
->header(
-type
=>
'text/html; charset=utf-8'
,
-Content_Length
=>
length
$content
) .
$content
;
}
$self
->quit();
}
sub
urlUpload {
my
$self
=
shift
;
my
$fieldname
=
shift
;
my
$content
=
''
;
my
$url
= ${
$self
->rparam(
$fieldname
) };
my
$content
= get
$url
;
$content
=
''
unless
(
defined
$content
);
$content
=~ s!<!
<
;!g;
$content
=~ s!>!
>
;!g;
my
$json
= new JSON();
my
$json_content
=
''
;
if
(
$JSON::VERSION
lt 2 ) {
local
$JSON::UTF8
= 1;
$json_content
=
$json
->objToJson( [
$content
] );
$json_content
=~ s/^\[//;
$json_content
=~ s/\]$//;
}
else
{
$json
=
$json
->allow_nonref( [
'1'
] );
$json
=
$json
->utf8( [
'1'
] );
$json_content
=
$json
->encode(
$content
);
}
$content
=
'{"status":"OK", "content":'
.
$json_content
.
'}'
;
print
$self
->header(
-type
=>
'text/html; charset=utf-8'
,
-Content_Length
=>
length
$content
) .
$content
;
}
sub
applyTest {
my
(
$self
,
$test
,
$value
) =
@_
;
my
(
$res
,
$msg
);
if
(
ref
(
$test
) eq
'CODE'
) {
(
$res
,
$msg
) =
&$test
(
$value
);
}
else
{
$res
= (
$value
=~
$test
? 1 : 0 );
}
return
(
$res
,
$msg
);
}
sub
getConfTests {
my
(
$self
,
$id
) =
@_
;
$self
->lmLog(
"getConfTests: get id $id"
,
'debug'
);
my
(
$confKey
,
$tmp
) = (
$id
=~ /^(.*?)(?:\/(.*))?$/ );
$self
->lmLog(
"getConfTests: split $id in $confKey and $tmp"
,
'debug'
)
if
defined
$tmp
;
my
$h
=
$self
->testStruct()->{
$confKey
};
if
(
$h
and
$h
->{
'*'
} and
my
(
$k
,
$v
) = (
$tmp
=~ /^(.*?)\/(.*)$/ ) ) {
$self
->lmLog(
"getConfKey: '*' in tests, return $confKey/$k"
,
'debug'
);
return
(
"$confKey/$k"
,
$h
->{
'*'
} );
}
$self
->lmLog(
"getConfTests: return $confKey"
,
'debug'
);
return
(
$confKey
,
$h
);
}
sub
findAllConfKeys {
my
(
$self
,
$h
) =
@_
;
my
@res
= ();
if
(
ref
(
$h
->{_nodes} ) eq
'CODE'
) {
$h
->{_nodes} =
$h
->{_nodes}->(
$self
);
}
foreach
my
$n
( @{
$h
->{_nodes} } ) {
$n
=~ s/^.*?:(.*?)(?:\:.*)?$/$1/;
$self
->lmLog(
"findAllConfKey: got node $n"
,
'debug'
);
if
(
ref
(
$h
->{
$n
} ) ) {
push
@res
,
$self
->findAllConfKeys(
$h
->{
$n
} );
}
else
{
my
$m
=
$h
->{
$n
} ||
$n
;
push
@res
, (
$m
=~ /^(?:.*?:)?(.*?)(?:\:.*)?$/ ? $1 : () );
}
}
push
@res
, @{
$h
->{_upload} }
if
(
$h
->{_upload} );
return
@res
;
}
sub
formatValue {
my
(
$self
,
$key
,
$value
) =
@_
;
return
$value
;
}
sub
setKeyToH {
my
$value
=
pop
;
return
unless
(
ref
(
$value
) or
length
(
$value
) );
my
(
$self
,
$h
,
$key
,
$k2
) =
@_
;
$self
->lmLog(
"setKeyToH: key $key / k2 $k2 / value $value"
,
'debug'
);
my
$tmp
=
$h
;
$key
=~ s/^\///;
$value
=
$self
->formatValue(
$key
,
$value
);
while
(1) {
if
(
$key
=~ /\// ) {
my
$k
= $`;
$key
= $';
$tmp
=
$tmp
->{
$k
} ||= {};
}
else
{
if
(
$k2
) {
unless
(
ref
(
$tmp
->{
$key
} ) ) {
$self
->lmLog(
"setKeyToH: k2 $k2 set, but $key is not a reference, create it"
,
'error'
);
$tmp
->{
$key
} = {};
}
if
(
ref
(
$value
) eq
'HASH'
) {
foreach
my
$vv
(
keys
%$value
) {
if
(
ref
(
$value
->{
$vv
} ) eq
'HASH'
) {
foreach
my
$vvv
(
keys
%{
$value
->{
$vv
} } ) {
$self
->lmLog(
"setKeyToH: set "
.
$value
->{
$vv
}->{
$vvv
}
.
" in key $vvv in key $vv in key $k2 inside key $key"
,
'debug'
);
$tmp
->{
$key
}->{
$k2
}->{
$vv
}->{
$vvv
} =
$value
->{
$vv
}->{
$vvv
};
}
}
else
{
$self
->lmLog(
"setKeyToH: set "
.
$value
->{
$vv
}
.
" in key $vv in key $k2 inside key $key"
,
'debug'
);
$tmp
->{
$key
}->{
$k2
}->{
$vv
} =
$value
->{
$vv
};
}
}
}
else
{
$self
->lmLog(
"setKeyToH: set $value in key $k2 inside key $key"
,
'debug'
);
$tmp
->{
$key
}->{
$k2
} =
$value
;
}
}
else
{
$self
->lmLog(
"setKeyToH: set $value in key $key"
,
'debug'
);
$tmp
->{
$key
} =
$value
;
}
last
;
}
}
}
sub
parser {
my
$self
=
shift
;
return
$parser
if
(
$parser
);
$parser
= XML::LibXML->new();
}
sub
stylesheet {
my
$self
=
shift
;
return
$stylesheet
if
(
$stylesheet
);
my
$xslt
= XML::LibXSLT->new();
my
$style_doc
=
$self
->parser->parse_string(
join
(
''
, <DATA> ) );
close
DATA;
$stylesheet
=
$xslt
->parse_stylesheet(
$style_doc
);
}
sub
applyConf {
my
$self
=
shift
;
my
$status
;
my
$localConf
=
$self
->confObj->getLocalConf( APPLYSECTION,
undef
, 0 );
my
$ua
= new LWP::UserAgent(
requests_redirectable
=> [] );
$ua
->timeout(10);
foreach
(
keys
%$localConf
) {
my
(
$host
,
$request
) = (
$_
,
$localConf
->{
$_
} );
my
(
$method
,
$vhost
,
$uri
) =
(
$request
=~ /^(https?):\/\/([^\/]+)(.*)$/ );
unless
(
$vhost
) {
$vhost
=
$host
;
$uri
=
$request
;
}
my
$r
=
HTTP::Request->new(
'GET'
,
"$method://$host$uri"
,
HTTP::Headers->new(
Host
=>
$vhost
) );
my
$response
=
$ua
->request(
$r
);
if
(
$response
->code != 200 ) {
$status
->{
$host
} =
"Error "
.
$response
->code .
" ("
.
$response
->message .
")"
;
$self
->_sub(
'userError'
,
"Apply configuration for $host: error "
.
$response
->code .
" ("
.
$response
->message
.
")"
);
}
else
{
$status
->{
$host
} =
"OK"
;
$self
->_sub(
'userNotice'
,
"Apply configuration for $host: ok"
);
}
}
return
$status
;
}
1;