907 lines
29 KiB
Perl
907 lines
29 KiB
Perl
package Lemonldap::NG::Common::Conf::RESTServer;
|
|
|
|
use strict;
|
|
use JSON 'from_json';
|
|
use Mouse;
|
|
use Lemonldap::NG::Common::Conf::Constants;
|
|
use Lemonldap::NG::Common::Conf::ReConstants;
|
|
|
|
our $VERSION = '2.1.0';
|
|
|
|
extends 'Lemonldap::NG::Common::Conf::AccessLib';
|
|
|
|
#######################
|
|
# I. PRIVATE METHODS #
|
|
#######################
|
|
|
|
## @method scalar getConfKey($req, $key)
|
|
# Return key value
|
|
#
|
|
# Return the value of $key key in current configuration. If cfgNum is set to
|
|
# `latest`, get before last configuration number.
|
|
#
|
|
# Errors: set an error in $req->error and return undef if:
|
|
# * query does not have a cfgNum parameter (set by Common/PSGI/Router.pm)
|
|
# * cfgNum is not a number
|
|
#
|
|
#@param $req Lemonldap::NG::Common::PSGI::Request
|
|
#@param $key Key name
|
|
#@return keyvalue (string, int or hashref)
|
|
sub getConfKey {
|
|
my ( $self, $req, $key, @args ) = @_;
|
|
$self->logger->debug("Search for $key in conf");
|
|
|
|
# Verify that cfgNum has been asked
|
|
unless ( defined $req->params('cfgNum') ) {
|
|
$req->error("Missing configuration number");
|
|
return undef;
|
|
}
|
|
$self->logger->debug( "Cfgnum set to " . $req->params('cfgNum') );
|
|
|
|
# when 'latest' => replace by last cfgNum
|
|
if ( $req->params('cfgNum') eq 'latest' ) {
|
|
my $tmp = $self->confAcc->lastCfg;
|
|
$req->set_param( 'cfgNum', $tmp );
|
|
unless ($tmp) {
|
|
$req->error($Lemonldap::NG::Common::Conf::msg)
|
|
if ($Lemonldap::NG::Common::Conf::msg);
|
|
return undef;
|
|
}
|
|
}
|
|
elsif ( $req->params('cfgNum') !~ /^\d+$/ ) {
|
|
$req->error("cfgNum must be a number");
|
|
return undef;
|
|
}
|
|
unless (
|
|
defined $self->getConfByNum( scalar( $req->params('cfgNum') ), @args ) )
|
|
{
|
|
$req->error( "Configuration "
|
|
. $req->params('cfgNum')
|
|
. " is not available ("
|
|
. $Lemonldap::NG::Common::Conf::msg
|
|
. ')' );
|
|
return undef;
|
|
}
|
|
|
|
# TODO: insert default values
|
|
# Set an error if key is not defined
|
|
return $self->currentConf->{$key};
|
|
}
|
|
|
|
sub getConfByNum {
|
|
my ( $self, $cfgNum, @args ) = @_;
|
|
unless ($self->currentConf
|
|
and %{ $self->currentConf }
|
|
and $cfgNum == $self->currentConf->{cfgNum} )
|
|
{
|
|
my $tmp = $self->confAcc->getConf(
|
|
{ cfgNum => $cfgNum, raw => 1, noCache => 1, @args } );
|
|
return undef unless ( $tmp and ref($tmp) and %$tmp );
|
|
$self->currentConf($tmp);
|
|
}
|
|
return $cfgNum;
|
|
}
|
|
|
|
########################
|
|
# II. Display methods #
|
|
########################
|
|
|
|
# Values are send depending of the /path/info/. For example,
|
|
# /confs/1/portal to get portal value.
|
|
|
|
# This section contains several methods:
|
|
# - complex nodes:
|
|
# * complexNodesRoot() call for root queries (no subkeys) to display the list
|
|
# * virtualHosts()
|
|
# * _samlMetaDataNodes() is called by saml(IDP|RP)MetaDataNode
|
|
# * _oidcMetaDataNodes() is called by oidc(OP|RP)MetaDataNodes
|
|
# - other special nodes:
|
|
# * authChoiceModules()
|
|
# * grantSessionRules()
|
|
# * openIdIDPList() (old OpenID)
|
|
# * applicationList()
|
|
# - root:
|
|
# root query (/confs/latest for example) is redirected to metadata()
|
|
# - other requests:
|
|
# they are managed by getKey()
|
|
# - newRSAKey() returns a new RSA key pair if /confs/newRSAKey is called in a
|
|
# POST request
|
|
# - prx() load a request and return the content (for SAML/OIDC metadata)
|
|
|
|
# 31 - Complex subnodes
|
|
# ----------------
|
|
|
|
## @method PSGI-JSON-response complexNodesRoot($req, $query, $tpl)
|
|
# Respond to root requests for virtual hosts and SAMLmetadata
|
|
#
|
|
#@param $req Lemonldap::NG::Common::PSGI::Request
|
|
#@param $query Configuration root key
|
|
#@param $tpl Javascript template to use (see JS/JSON generator script)
|
|
#@return PSGI JSON response
|
|
sub complexNodesRoot {
|
|
my ( $self, $req, $query, $tpl ) = @_;
|
|
$self->logger->debug("Query for $query template keys");
|
|
|
|
my $tmp = $self->getConfKey( $req, $query );
|
|
return $self->sendError( $req, undef, 400 ) if ( $req->error );
|
|
|
|
my @res;
|
|
if ( ref($tmp) ) {
|
|
foreach my $f ( sort keys %$tmp ) {
|
|
push @res,
|
|
{
|
|
id => "${tpl}s/$f",
|
|
title => $f,
|
|
type => $tpl,
|
|
template => $tpl
|
|
};
|
|
}
|
|
}
|
|
return $self->sendJSONresponse( $req, \@res );
|
|
}
|
|
|
|
# 311 - Virtual hosts
|
|
# -------------
|
|
|
|
## @method PSGI-JSON-response virtualHosts($req, @path)
|
|
# Respond to virtualhosts sub requests
|
|
#
|
|
#@param $req Lemonldap::NG::Common::PSGI::Request
|
|
#@param @path words in path after `virtualhosts`
|
|
#@return PSGI JSON response
|
|
sub virtualHosts {
|
|
my ( $self, $req, @path ) = @_;
|
|
|
|
return $self->complexNodesRoot( $req, 'locationRules', 'virtualHost' )
|
|
unless (@path);
|
|
|
|
my $vh = shift @path;
|
|
my $query;
|
|
unless ( $query = shift @path ) {
|
|
return $self->sendError( $req,
|
|
'Bad request: virtualHost query must ask for a key', 400 );
|
|
}
|
|
|
|
# Send setDefault for new vhosts
|
|
return $self->sendError( $req, 'setDefault', 200 ) if ( $vh =~ /^new__/ );
|
|
|
|
# Reject unknown vhosts
|
|
return $self->sendError( $req, "Unknown virtualhost ($vh)", 400 )
|
|
unless ( defined $self->getConfKey( $req, 'locationRules' )->{$vh} );
|
|
|
|
if ( $query =~ /^(?:(?:exportedHeader|locationRule)s|post)$/ ) {
|
|
my ( $id, $resp ) = ( 1, [] );
|
|
my $vhk = eval { $self->getConfKey( $req, $query )->{$vh} } // {};
|
|
return $self->sendError( $req, undef, 400 ) if ( $req->error );
|
|
$self->logger->debug("Query for $vh/$query keys");
|
|
|
|
# Keys are ordered except 'default' which must be at the end
|
|
foreach my $r (
|
|
sort {
|
|
$query eq 'locationRules'
|
|
? (
|
|
$a eq 'default'
|
|
? 1
|
|
: ( $b eq 'default' ? -1 : $a cmp $b )
|
|
)
|
|
: $a cmp $b
|
|
} keys %$vhk
|
|
)
|
|
{
|
|
my $res = {
|
|
id => "virtualHosts/$vh/$query/" . $id++,
|
|
title => $r,
|
|
data => $vhk->{$r},
|
|
type => 'keyText',
|
|
};
|
|
|
|
# If rule contains a comment or an AuthLevel, split them
|
|
if ( $query eq 'locationRules' ) {
|
|
$res->{comment} = '';
|
|
$res->{level} = '';
|
|
$res->{level} = $1 if ( $r =~ s/\(\?#AuthnLevel=(-?\d+)\)// );
|
|
if ( $r =~ s/\(\?#(.*?)\)// ) {
|
|
$res->{title} = $res->{comment} = $1;
|
|
}
|
|
$res->{re} = $r;
|
|
$res->{type} = 'rule';
|
|
}
|
|
elsif ( $query eq 'post' ) {
|
|
$res->{data} = $vhk->{$r};
|
|
$res->{type} = 'post';
|
|
}
|
|
push @$resp, $res;
|
|
}
|
|
return $self->sendJSONresponse( $req, $resp );
|
|
}
|
|
elsif ( $query =~ qr/^$virtualHostKeys$/o ) {
|
|
$self->logger->debug("Query for $vh/$query key");
|
|
|
|
# TODO: verify how this is done actually
|
|
my $k1 = $self->getConfKey( $req, 'vhostOptions' );
|
|
return $self->sendError( $req, undef, 400 ) if ( $req->error );
|
|
|
|
# Default values are set by JS
|
|
my $res = eval { $k1->{$vh}->{$query} } // undef;
|
|
return $self->sendJSONresponse( $req, { value => $res } );
|
|
}
|
|
else {
|
|
return $self->sendError( $req, "Unknown vhost subkey ($query)", 400 );
|
|
}
|
|
}
|
|
|
|
# 312 - SAML
|
|
# ----
|
|
|
|
## @method PSGI-JSON-response _samlMetaDataNode($type, $req, @path)
|
|
# Respond to SAML metadata subnodes
|
|
#
|
|
#@param $type `SP` or `IDP`
|
|
#@param $req Lemonldap::NG::Common::PSGI::Request
|
|
#@param @path words in path after `saml{IDP|SP}MetaDataNode`
|
|
#@return PSGI JSON response
|
|
sub _samlMetaDataNodes {
|
|
my ( $self, $type, $req, @path ) = @_;
|
|
|
|
return $self->complexNodesRoot( $req, "saml${type}MetaDataXML",
|
|
"saml${type}MetaDataNode" )
|
|
unless (@path);
|
|
my $partner = shift @path;
|
|
my $query = shift @path;
|
|
unless ($query) {
|
|
return $self->sendError( $req,
|
|
"Bad request: saml${type}MetaDataNode query must ask for a key",
|
|
400 );
|
|
}
|
|
|
|
# setDefault response for new partners
|
|
return $self->sendError( $req, 'setDefault', 200 )
|
|
if ( $partner =~ /^new__/ );
|
|
|
|
# Reject unknown partners
|
|
return $self->sendError( $req, "Unknown SAML partner ($partner)", 400 )
|
|
unless (
|
|
defined eval {
|
|
$self->getConfKey( $req, "saml${type}MetaDataXML" )->{$partner};
|
|
}
|
|
);
|
|
|
|
my ( $id, $resp ) = ( 1, [] );
|
|
|
|
# Return all exported attributes if asked
|
|
if ( $query =~ /^saml${type}MetaDataExportedAttributes$/ ) {
|
|
my $pk =
|
|
eval { $self->getConfKey( $req, $query )->{$partner} } // {};
|
|
return $self->sendError( $req, undef, 400 ) if ( $req->error );
|
|
foreach my $h ( sort keys %$pk ) {
|
|
push @$resp,
|
|
{
|
|
id => "saml${type}MetaDataNodes/$partner/$query/" . $id++,
|
|
title => $h,
|
|
data => [ split /;/, $pk->{$h} ],
|
|
type => 'samlAttribute',
|
|
};
|
|
}
|
|
return $self->sendJSONresponse( $req, $resp );
|
|
}
|
|
elsif ( $query eq "samlSPMetaDataMacros" ) {
|
|
my $pk =
|
|
eval { $self->getConfKey( $req, $query )->{$partner} } // {};
|
|
return $self->sendError( $req, undef, 400 ) if ( $req->error );
|
|
foreach my $h ( sort keys %$pk ) {
|
|
push @$resp,
|
|
{
|
|
id => "saml${type}MetaDataNodes/$partner/$query/" . $id++,
|
|
title => $h,
|
|
data => $pk->{$h},
|
|
type => 'keyText',
|
|
};
|
|
}
|
|
return $self->sendJSONresponse( $req, $resp );
|
|
}
|
|
|
|
# Simple root keys
|
|
elsif ( $query =~ /^saml${type}MetaDataXML$/ ) {
|
|
my $value =
|
|
eval { $self->getConfKey( $req, $query )->{$partner}->{$query}; }
|
|
// undef;
|
|
return $self->sendError( $req, undef, 400 ) if ( $req->error );
|
|
return $self->sendJSONresponse( $req, { value => $value } );
|
|
}
|
|
|
|
# These regexps are generated by jsongenerator.pl and stored in
|
|
# Lemonldap::NG::Common::Conf::ReConstants
|
|
elsif (
|
|
$query =~ {
|
|
IDP => qr/^$samlIDPMetaDataNodeKeys$/o,
|
|
SP => qr/^$samlSPMetaDataNodeKeys$/o
|
|
}->{$type}
|
|
)
|
|
{
|
|
my $value = eval {
|
|
$self->getConfKey( $req, "saml${type}MetaDataOptions" )->{$partner}
|
|
->{$query};
|
|
} // undef;
|
|
|
|
# Note that types "samlService" and "samlAssertion" will be splitted by
|
|
# manager.js in an array
|
|
return $self->sendJSONresponse( $req, { value => $value } );
|
|
}
|
|
else {
|
|
return $self->sendError( $req,
|
|
"Bad key for saml${type}MetaDataNode ($query)", 400 );
|
|
}
|
|
}
|
|
|
|
## @method PSGI-JSON-response samlIDPMetaDataNode($req, @path)
|
|
# Launch _samlMetaDataNode('IDP', @_)
|
|
#
|
|
#@param $req Lemonldap::NG::Common::PSGI::Request
|
|
#@param @path words in path after `samlIDPMetaDataNode`
|
|
#@return PSGI JSON response
|
|
sub samlIDPMetaDataNodes {
|
|
my ( $self, $req, @path ) = @_;
|
|
return $self->_samlMetaDataNodes( 'IDP', $req, @path );
|
|
}
|
|
|
|
## @method PSGI-JSON-response samlSPMetaDataNode($req, @path)
|
|
# Launch _samlMetaDataNode('SP', @_)
|
|
#
|
|
#@param $req Lemonldap::NG::Common::PSGI::Request
|
|
#@param @path words in path after `samlSPMetaDataNode`
|
|
#@return PSGI JSON response
|
|
sub samlSPMetaDataNodes {
|
|
my ( $self, $req, @path ) = @_;
|
|
return $self->_samlMetaDataNodes( 'SP', $req, @path );
|
|
}
|
|
|
|
# 313 - OpenID-Connect
|
|
# --------------
|
|
|
|
## @method PSGI-JSON-response _oidcMetaDataNodes($type, $req, @path)
|
|
# Respond to OpenID-Connect metadata subnodes
|
|
#
|
|
#@param $type `OP` or `RP`
|
|
#@param $req Lemonldap::NG::Common::PSGI::Request
|
|
#@param @path words in path after `oidc{OP|RP}MetaDataNode`
|
|
#@return PSGI JSON response
|
|
sub _oidcMetaDataNodes {
|
|
my ( $self, $type, $req, @path ) = @_;
|
|
|
|
my $refKey =
|
|
( $type eq 'RP' ? 'oidcRPMetaDataOptions' : 'oidcOPMetaDataJSON' );
|
|
return $self->complexNodesRoot( $req, $refKey, "oidc${type}MetaDataNode" )
|
|
unless (@path);
|
|
|
|
my $partner = shift @path;
|
|
my $query = shift @path;
|
|
unless ($query) {
|
|
return $self->sendError( $req,
|
|
"Bad request: oidc${type}MetaDataNode query must ask for a key",
|
|
400 );
|
|
}
|
|
|
|
# setDefault response for new partners
|
|
return $self->sendError( $req, 'setDefault', 200 )
|
|
if ( $partner =~ /^new__/ );
|
|
|
|
# Reject unknown partners
|
|
return $self->sendError( $req,
|
|
"Unknown OpenID-Connect partner ($partner)", 400 )
|
|
unless ( defined eval { $self->getConfKey( $req, $refKey )->{$partner}; }
|
|
);
|
|
|
|
my ( $id, $resp ) = ( 1, [] );
|
|
|
|
# Handle RP Attributes
|
|
if ($query eq "oidcRPMetaDataExportedVars") {
|
|
my $pk = eval { $self->getConfKey( $req, $query )->{$partner} } // {};
|
|
return $self->sendError( $req, undef, 400 ) if ( $req->error );
|
|
foreach my $h ( sort keys %$pk ) {
|
|
# Set default values for type and array
|
|
my $data = [ split /;/, $pk->{$h} ];
|
|
unless ( $data->[1]) {
|
|
$data->[1] = "string";
|
|
}
|
|
unless ( $data->[2]) {
|
|
$data->[2] = "auto";
|
|
}
|
|
push @$resp,
|
|
{
|
|
id => "oidc${type}MetaDataNodes/$partner/$query/" . $id++,
|
|
title => $h,
|
|
data => $data,
|
|
type => 'oidcAttribute',
|
|
};
|
|
}
|
|
return $self->sendJSONresponse( $req, $resp );
|
|
}
|
|
# Return all exported attributes if asked
|
|
elsif ( $query =~
|
|
/^(?:oidc${type}MetaDataExportedVars|oidcRPMetaDataOptionsExtraClaims|oidcRPMetaDataMacros|oidcRPMetaDataScopeRules)$/
|
|
)
|
|
{
|
|
my $pk = eval { $self->getConfKey( $req, $query )->{$partner} } // {};
|
|
return $self->sendError( $req, undef, 400 ) if ( $req->error );
|
|
foreach my $h ( sort keys %$pk ) {
|
|
push @$resp,
|
|
{
|
|
id => "oidc${type}MetaDataNodes/$partner/$query/" . $id++,
|
|
title => $h,
|
|
data => $pk->{$h},
|
|
type => 'keyText',
|
|
};
|
|
}
|
|
return $self->sendJSONresponse( $req, $resp );
|
|
}
|
|
|
|
# Long text types (OP only)
|
|
elsif ( $query =~ /^oidcOPMetaData(?:JSON|JWKS)$/ ) {
|
|
my $value =
|
|
eval { $self->getConfKey( $req, $query )->{$partner}; } // undef;
|
|
return $self->sendError( $req, undef, 400 ) if ( $req->error );
|
|
return $self->sendJSONresponse( $req, { value => $value } );
|
|
}
|
|
|
|
# Options
|
|
elsif (
|
|
$query =~ {
|
|
OP => qr/^$oidcOPMetaDataNodeKeys$/o,
|
|
RP => qr/^$oidcRPMetaDataNodeKeys$/o
|
|
}->{$type}
|
|
)
|
|
{
|
|
my $value = eval {
|
|
$self->getConfKey( $req, "oidc${type}MetaDataOptions" )->{$partner}
|
|
->{$query};
|
|
} // undef;
|
|
return $self->sendJSONresponse( $req, { value => $value } );
|
|
}
|
|
else {
|
|
return $self->sendError( $req,
|
|
"Bad key for oidc${type}MetaDataNode ($query)", 400 );
|
|
}
|
|
}
|
|
|
|
## @method PSGI-JSON-response oidcOPMetaDataNodes($req, @path)
|
|
# Launch _oidcMetaDataNodes('SP', @_)
|
|
#
|
|
#@param $req Lemonldap::NG::Common::PSGI::Request
|
|
#@param @path words in path after `oidcOPMetaDataNode`
|
|
#@return PSGI JSON response
|
|
sub oidcOPMetaDataNodes {
|
|
my ( $self, $req, @path ) = @_;
|
|
return $self->_oidcMetaDataNodes( 'OP', $req, @path );
|
|
}
|
|
|
|
## @method PSGI-JSON-response oidcRPMetaDataNodes($req, @path)
|
|
# Launch _oidcMetaDataNodes('SP', @_)
|
|
#
|
|
#@param $req Lemonldap::NG::Common::PSGI::Request
|
|
#@param @path words in path after `oidcRPMetaDataNode`
|
|
#@return PSGI JSON response
|
|
sub oidcRPMetaDataNodes {
|
|
my ( $self, $req, @path ) = @_;
|
|
return $self->_oidcMetaDataNodes( 'RP', $req, @path );
|
|
}
|
|
|
|
# 314 - CAS
|
|
# ---
|
|
|
|
sub _casMetaDataNodes {
|
|
my ( $self, $type, $req, @path ) = @_;
|
|
my $refKey =
|
|
( $type eq 'App' ? 'casAppMetaDataOptions' : 'casSrvMetaDataOptions' );
|
|
return $self->complexNodesRoot( $req, $refKey, "cas${type}MetaDataNode" )
|
|
unless (@path);
|
|
|
|
my $partner = shift @path;
|
|
my $query = shift @path;
|
|
unless ($query) {
|
|
return $self->sendError( $req,
|
|
"Bad request: cas${type}MetaDataNode query must ask for a key",
|
|
400 );
|
|
}
|
|
|
|
# setDefault response for new partners
|
|
return $self->sendError( $req, 'setDefault', 200 )
|
|
if ( $partner =~ /^new__/ );
|
|
|
|
# Reject unknown partners
|
|
return $self->sendError( $req, "Unknown CAS partner ($partner)", 400 )
|
|
unless ( defined eval { $self->getConfKey( $req, $refKey )->{$partner}; }
|
|
);
|
|
|
|
my ( $id, $resp ) = ( 1, [] );
|
|
|
|
# Return all exported attributes if asked
|
|
if ( $query =~
|
|
/^(?:cas${type}MetaDataExportedVars|casSrvMetaDataOptionsProxiedServices|casAppMetaDataMacros)$/
|
|
)
|
|
{
|
|
my $pk = eval { $self->getConfKey( $req, $query )->{$partner} } // {};
|
|
return $self->sendError( $req, undef, 400 ) if ( $req->error );
|
|
foreach my $h ( sort keys %$pk ) {
|
|
push @$resp,
|
|
{
|
|
id => "cas${type}MetaDataNodes/$partner/$query/" . $id++,
|
|
title => $h,
|
|
data => $pk->{$h},
|
|
type => 'keyText',
|
|
};
|
|
}
|
|
return $self->sendJSONresponse( $req, $resp );
|
|
}
|
|
|
|
# Options
|
|
if (
|
|
$query =~ {
|
|
App => qr/^$casAppMetaDataNodeKeys$/o,
|
|
Srv => qr/^$casSrvMetaDataNodeKeys$/o
|
|
}->{$type}
|
|
)
|
|
{
|
|
my $value = eval {
|
|
$self->getConfKey( $req, "cas${type}MetaDataOptions" )->{$partner}
|
|
->{$query};
|
|
} // undef;
|
|
return $self->sendJSONresponse( $req, { value => $value } );
|
|
}
|
|
else {
|
|
return $self->sendError( $req,
|
|
"Bad key for cas${type}MetaDataNode ($query)", 400 );
|
|
}
|
|
}
|
|
|
|
sub casSrvMetaDataNodes {
|
|
my ( $self, $req, @path ) = @_;
|
|
return $self->_casMetaDataNodes( 'Srv', $req, @path );
|
|
}
|
|
|
|
sub casAppMetaDataNodes {
|
|
my ( $self, $req, @path ) = @_;
|
|
return $self->_casMetaDataNodes( 'App', $req, @path );
|
|
}
|
|
|
|
# 32 - Other special nodes
|
|
# -------------------
|
|
|
|
# 321 - Choice authentication
|
|
|
|
## @method PSGI-JSON-response authChoiceModules($req,$key)
|
|
# Returns authChoiceModules keys splitted in arrays
|
|
#
|
|
#@param $req Lemonldap::NG::Common::PSGI::Request
|
|
#@param key optional subkey
|
|
#@return PSGI JSON response
|
|
sub authChoiceModules {
|
|
my ( $self, $req, $key ) = @_;
|
|
my $value = $self->getConfKey( $req, 'authChoiceModules' );
|
|
unless ($key) {
|
|
my @res;
|
|
foreach my $k ( sort keys %$value ) {
|
|
my $data = [ split /;/, $value->{$k} ];
|
|
if ( $data->[5] ) {
|
|
my $over;
|
|
eval { $over = from_json( $data->[5] ) };
|
|
if ($@) {
|
|
$self->logger->error(
|
|
"Bad value in choice over parameters, deleted ($@)");
|
|
}
|
|
else {
|
|
$data->[5] = [ map { [ $_, $over->{$_} ] } keys %{$over} ];
|
|
}
|
|
}
|
|
push @res,
|
|
{
|
|
id => "authChoiceModules/$k",
|
|
title => "$k",
|
|
data => $data,
|
|
type => 'authChoice'
|
|
};
|
|
}
|
|
return $self->sendJSONresponse( $req, \@res );
|
|
}
|
|
else {
|
|
my $r = $value->{$key} ? [ split( /[;\|]/, $value->{$key} ) ] : [];
|
|
return $self->sendJSONresponse( $req, { value => $r } );
|
|
}
|
|
}
|
|
|
|
# 322 - Rules to grant sessions
|
|
|
|
## @method PSGI-JSON-response grantSessionRules($req)
|
|
# Split grantSessionRules key=>value into 3 elements
|
|
#
|
|
#@param $req Lemonldap::NG::Common::PSGI::Request
|
|
#@return PSGI JSON response
|
|
sub grantSessionRules {
|
|
my ( $self, $req, $key ) = @_;
|
|
return $self->sendError( $req, 'Subkeys forbidden for grantSessionRules',
|
|
400 )
|
|
if ($key);
|
|
my $value = $self->getConfKey( $req, 'grantSessionRules' );
|
|
my @res;
|
|
|
|
sub _sort {
|
|
my $A = ( $a =~ /^.*?##(.*)$/ )[0];
|
|
my $B = ( $b =~ /^.*?##(.*)$/ )[0];
|
|
return !$A ? 1 : !$B ? -1 : $A cmp $B;
|
|
}
|
|
my $id = 0;
|
|
foreach my $k ( sort _sort keys %$value ) {
|
|
my $r = $k;
|
|
my $c = ( $r =~ s/^(.*)?##(.*)$/$1/ ? $2 : '' );
|
|
$id++;
|
|
push @res,
|
|
{
|
|
id => "grantSessionRules/$id",
|
|
title => $c || $r,
|
|
re => $r,
|
|
comment => $c,
|
|
data => $value->{$k},
|
|
type => 'grant'
|
|
};
|
|
}
|
|
return $self->sendJSONresponse( $req, \@res );
|
|
}
|
|
|
|
# 323 - (old)OpenID IDP black/white list
|
|
|
|
##method PSGI-JSON-response openIdIDPList($req)
|
|
# Split openIdIDPList parameter into 2 elements
|
|
sub openIdIDPList {
|
|
my ( $self, $req, $key ) = @_;
|
|
return $self->sendError( $req, 'Subkeys forbidden for openIdIDPList', 400 )
|
|
if ($key);
|
|
my $value = $self->getConfKey( $req, 'openIdIDPList' );
|
|
$value //= '0;';
|
|
my ( $type, $v ) = split /;/, $value;
|
|
$v //= '';
|
|
return $self->sendJSONresponse( $req, { value => [ $type, $v ] } );
|
|
}
|
|
|
|
# 324 - Application for menu
|
|
# --------------------
|
|
|
|
## @method PSGI-JSON-response applicationList($req, @other)
|
|
# Return the full menu tree
|
|
#
|
|
#@param $req Lemonldap::NG::Common::PSGI::Request
|
|
#@param @other words in path after `applicationList`
|
|
#@return PSGI JSON response
|
|
sub applicationList {
|
|
my ( $self, $req, @other ) = @_;
|
|
return $self->sendError( $req,
|
|
'There is no subkey for applicationList', 400 )
|
|
if (@other);
|
|
my $apps = $self->getConfKey( $req, 'applicationList' );
|
|
return $self->sendError( $req, undef, 400 ) if ( $req->error );
|
|
$apps = {} unless ( ref($apps) eq 'HASH' );
|
|
my $json = $self->_scanCatsAndApps( $apps, 'applicationList' );
|
|
return $self->sendJSONresponse( $req, $json );
|
|
}
|
|
|
|
## @method arrayRef _scanCatsAndApps($apps)
|
|
# Recursive method used to build categories & applications menu
|
|
#
|
|
#@param $apps HashRef pointing to a subnode of catAndApps conf tree
|
|
#@return arrayRef
|
|
sub _scanCatsAndApps {
|
|
my ( $self, $apps, $baseId ) = @_;
|
|
my @res;
|
|
|
|
foreach my $cat (
|
|
sort {
|
|
( $apps->{$a}->{order} || 0 ) <=> ( $apps->{$b}->{order} || 0 )
|
|
or $a cmp $b
|
|
}
|
|
grep { not /^(?:catname|type|order)$/ } keys %$apps
|
|
)
|
|
{
|
|
my $item = { id => "$baseId/$cat" };
|
|
if ( $apps->{$cat}->{type} eq 'category' ) {
|
|
$item->{title} = $apps->{$cat}->{catname};
|
|
$item->{type} = 'menuCat';
|
|
$item->{nodes} =
|
|
$self->_scanCatsAndApps( $apps->{$cat}, "$baseId/$cat" );
|
|
}
|
|
else {
|
|
$item->{title} = $apps->{$cat}->{options}->{name};
|
|
$item->{type} = $apps->{$cat}->{type} = 'menuApp';
|
|
foreach my $o (
|
|
grep { not /^name$/ }
|
|
keys %{ $apps->{$cat}->{options} }
|
|
)
|
|
{
|
|
$item->{data}->{$o} = $apps->{$cat}->{options}->{$o};
|
|
}
|
|
}
|
|
push @res, $item;
|
|
}
|
|
return \@res;
|
|
}
|
|
|
|
# 325 - Combination modules
|
|
|
|
# Returns raw value, just transform "over" key
|
|
sub combModules {
|
|
my ( $self, $req, $key ) = @_;
|
|
return $self->sendError( $req, 'Subkeys forbidden for combModules', 400 )
|
|
if ($key);
|
|
my $val = $self->getConfKey( $req, 'combModules' ) // {};
|
|
my $res = [];
|
|
foreach my $mod ( keys %$val ) {
|
|
my $tmp;
|
|
$tmp->{title} = $mod;
|
|
$tmp->{id} = "combModules/$mod";
|
|
$tmp->{type} = 'cmbModule';
|
|
$tmp->{data}->{$_} = $val->{$mod}->{$_} foreach (qw(type for));
|
|
my $over = $val->{$mod}->{over} // {};
|
|
$tmp->{data}->{over} = [ map { [ $_, $over->{$_} ] } keys %$over ];
|
|
push @$res, $tmp;
|
|
}
|
|
return $self->sendJSONresponse( $req, $res );
|
|
}
|
|
|
|
sub sfExtra {
|
|
my ( $self, $req, $key ) = @_;
|
|
return $self->sendError( $req, 'Subkeys forbidden for sfExtra', 400 )
|
|
if ($key);
|
|
my $val = $self->getConfKey( $req, 'sfExtra' ) // {};
|
|
my $res = [];
|
|
foreach my $mod ( keys %$val ) {
|
|
my $tmp;
|
|
$tmp->{title} = $mod;
|
|
$tmp->{id} = "sfExtra/$mod";
|
|
$tmp->{type} = 'sfExtra';
|
|
$tmp->{data}->{$_} = $val->{$mod}->{$_}
|
|
foreach (qw(type rule logo level label));
|
|
my $over = $val->{$mod}->{over} // {};
|
|
$tmp->{data}->{over} = [ map { [ $_, $over->{$_} ] } keys %$over ];
|
|
push @$res, $tmp;
|
|
}
|
|
return $self->sendJSONresponse( $req, $res );
|
|
}
|
|
|
|
# 33 - Root queries
|
|
# -----------
|
|
|
|
## @method PSGI-JSON-response metadata($req)
|
|
# Respond to `/conf/:cfgNum` requests by sending configuration metadata
|
|
#
|
|
# NB: if `full=1` is set in the query, configuration is returned directly in
|
|
# JSON
|
|
#
|
|
#@param $req Lemonldap::NG::Common::PSGI::Request
|
|
#@return PSGI JSON response
|
|
sub metadata {
|
|
my ( $self, $req ) = @_;
|
|
if ( $req->params('full') and $req->params('full') !~ NO ) {
|
|
my $c = $self->getConfKey( $req, 'cfgNum' );
|
|
return $self->sendError( $req, undef, 400 ) if ( $req->error );
|
|
if ( $self->can('userId') ) {
|
|
$self->userLogger->notice( 'User '
|
|
. $self->userId($req)
|
|
. ' ask for full configuration '
|
|
. $c );
|
|
}
|
|
else {
|
|
$self->logger->info("REST request to get full configuration $c");
|
|
}
|
|
return $self->sendJSONresponse(
|
|
$req,
|
|
$self->currentConf,
|
|
pretty => 1,
|
|
headers => [
|
|
'Content-Disposition' => "Attachment; filename=lmConf-$c.json"
|
|
],
|
|
);
|
|
}
|
|
else {
|
|
my $res = {};
|
|
$res->{cfgNum} = $self->getConfKey( $req, 'cfgNum' );
|
|
return $self->sendError( $req, undef, 400 ) if ( $req->error );
|
|
return $self->sendError( $req, "Configuration without cfgNum", 500 )
|
|
unless ( defined $res->{cfgNum} );
|
|
foreach my $key (qw(cfgAuthor cfgDate cfgAuthorIP cfgLog cfgVersion)) {
|
|
$res->{$key} = $self->getConfKey( $req, $key );
|
|
}
|
|
|
|
# Find next and previous conf
|
|
my @a = $self->confAcc->available;
|
|
my $id = -1;
|
|
my ($ind) = map { $id++; $_ == $res->{cfgNum} ? ($id) : () } @a;
|
|
if ($ind) { $res->{prev} = $a[ $ind - 1 ]; }
|
|
if ( defined $ind and $ind < $#a ) {
|
|
$res->{next} = $a[ $ind + 1 ];
|
|
}
|
|
if ( $self->can('userId') ) {
|
|
$self->userLogger->info( 'User '
|
|
. $self->userId($req)
|
|
. ' ask for configuration metadata ('
|
|
. $res->{cfgNum}
|
|
. ')' );
|
|
}
|
|
else {
|
|
$self->logger->info(
|
|
"REST request to get configuration metadata ($res->{cfgNum})");
|
|
}
|
|
return $self->sendJSONresponse( $req, $res );
|
|
}
|
|
}
|
|
|
|
# 34 - Other values
|
|
# ------------
|
|
|
|
## @method PSGI-JSON-response getKey($req, $key, $subkey)
|
|
# Return the value of a root key of current configuration
|
|
#
|
|
#@param $req Lemonldap::NG::Common::PSGI::Request
|
|
#@param $key Name of key requested
|
|
#@param $subkey Subkey for hash values
|
|
#@return PSGI JSON response
|
|
sub getKey {
|
|
my ( $self, $req, $key, $subkey ) = @_;
|
|
unless ($key) {
|
|
return $self->metadata($req);
|
|
}
|
|
if ( $self->can('userId') ) {
|
|
$self->userLogger->info(
|
|
'User ' . $self->userId($req) . " asks for key $key" );
|
|
}
|
|
else {
|
|
$self->logger->info("REST request to get configuration key $key");
|
|
}
|
|
my $value = $self->getConfKey( $req, $key );
|
|
return $self->sendError( $req, undef, 400 ) if ( $req->error );
|
|
|
|
# When "hash"
|
|
if ( $key =~ qr/^$simpleHashKeys$/o ) {
|
|
return $self->sendError( $req, 'setDefault', 200 )
|
|
unless defined($value);
|
|
|
|
# If a hash key is asked return its value
|
|
if ($subkey) {
|
|
return $self->sendJSONresponse( $req,
|
|
{ value => $value->{$subkey} // undef, } );
|
|
}
|
|
|
|
# else return the list of keys
|
|
my @res;
|
|
foreach my $k ( sort keys %$value ) {
|
|
push @res,
|
|
{
|
|
id => "$key/$k",
|
|
title => "$k",
|
|
data => $value->{$k},
|
|
type => 'keyText'
|
|
};
|
|
}
|
|
return $self->sendJSONresponse( $req, \@res );
|
|
}
|
|
elsif ( $key =~ qr/^$doubleHashKeys$/o ) {
|
|
my @res;
|
|
$value ||= {};
|
|
foreach my $host ( sort keys %$value ) {
|
|
my @tmp;
|
|
foreach my $k ( sort keys %{ $value->{$host} } ) {
|
|
push @tmp, { k => $k, v => $value->{$host}->{$k} };
|
|
}
|
|
push @res, { k => $host, h => \@tmp };
|
|
}
|
|
return $self->sendJSONresponse( $req, { value => \@res } );
|
|
}
|
|
|
|
# When scalar
|
|
return $self->sendError( $req, "Key $key is not a hash", 400 )
|
|
if ($subkey);
|
|
return $self->sendError( $req, 'setDefault', 200 )
|
|
unless defined($value);
|
|
return $self->sendJSONresponse( $req, { value => $value } );
|
|
|
|
# TODO authParam key
|
|
}
|
|
|
|
1;
|