our
$VERSION
=
'1.1200'
;
use
JSON
qw(from_json to_json)
;
has
auth_url
=> (
is
=>
'rw'
,
required
=> 1);
has
user
=> (
is
=>
'ro'
,
required
=> 1);
has
password
=> (
is
=>
'ro'
,
required
=> 1);
has
project_id
=> (
is
=>
'ro'
);
has
region
=> (
is
=>
'ro'
);
has
service_name
=> (
is
=>
'ro'
);
has
is_rax_auth
=> (
is
=>
'ro'
);
has
verify_ssl
=> (
is
=>
'ro'
,
default
=>
sub
{!
$ENV
{OSCOMPUTE_INSECURE}});
has
base_url
=> (
is
=>
'ro'
,
lazy
=> 1,
default
=>
sub
{
shift
->_auth_info->{base_url} },
);
has
token
=> (
is
=>
'ro'
,
lazy
=> 1,
default
=>
sub
{
shift
->_auth_info->{token} },
);
has
_auth_info
=> (
is
=>
'ro'
,
lazy
=> 1,
builder
=>
'_build_auth_info'
);
has
_agent
=> (
is
=>
'ro'
,
lazy
=> 1,
default
=>
sub
{
my
$self
=
shift
;
my
$agent
= LWP::UserAgent->new(
ssl_opts
=> {
verify_hostname
=>
$self
->verify_ssl });
return
$agent
;
},
);
sub
new_from_env {
my
(
$self
,
%params
) =
@_
;
my
$msg
=
"%s env var is required. Did you forget to source novarc?\n"
;
die
sprintf
(
$msg
,
'NOVA_URL or OS_AUTH_URL'
)
unless
$ENV
{NOVA_URL} ||
$ENV
{OS_AUTH_URL};
die
sprintf
(
$msg
,
'NOVA_USERNAME or OS_USERNAME'
)
unless
$ENV
{NOVA_USERNAME} ||
$ENV
{OS_USERNAME};
die
sprintf
(
$msg
,
'NOVA_PASSWORD or NOVA_API_KEY or OS_PASSWORD'
)
unless
$ENV
{NOVA_PASSWORD} ||
$ENV
{NOVA_API_KEY} ||
$ENV
{OS_PASSWORD};
my
%env
= (
auth_url
=>
$ENV
{NOVA_URL} ||
$ENV
{OS_AUTH_URL},
user
=>
$ENV
{NOVA_USERNAME} ||
$ENV
{OS_USERNAME},
password
=>
$ENV
{NOVA_PASSWORD} ||
$ENV
{NOVA_API_KEY}
||
$ENV
{OS_PASSWORD},
project_id
=>
$ENV
{NOVA_PROJECT_ID} ||
$ENV
{OS_TENANT_NAME},
region
=>
$ENV
{NOVA_REGION_NAME} ||
$ENV
{OS_AUTH_REGION},
service_name
=>
$ENV
{NOVA_SERVICE_NAME},
is_rax_auth
=>
$ENV
{NOVA_RAX_AUTH},
);
return
Net::OpenStack::Compute->new(
%env
,
%params
);
}
sub
BUILD {
my
(
$self
) =
@_
;
my
$auth_url
=
$self
->auth_url;
$auth_url
=~ s|/+$||;
$self
->auth_url(
$auth_url
);
}
sub
_build_auth_info {
my
(
$self
) =
@_
;
my
$auth_info
=
$self
->get_auth_info();
$self
->_agent->default_header(
x_auth_token
=>
$auth_info
->{token});
return
$auth_info
;
}
sub
_get_query {
my
%params
=
@_
;
my
$q
=
$params
{query} or
return
''
;
for
(
$q
) { s/^/?/
unless
/^\?/ }
return
$q
;
};
sub
get_servers {
my
(
$self
,
%params
) =
@_
;
my
$q
= _get_query(
%params
);
my
$res
=
$self
->_get(
$self
->_url(
"/servers"
,
$params
{detail},
$q
));
return
from_json(
$res
->content)->{servers};
}
sub
get_server {
my
(
$self
,
$id
) =
@_
;
croak
"Invalid server id"
unless
$id
;
my
$res
=
$self
->_get(
$self
->_url(
"/servers/$id"
));
return
undef
unless
$res
->is_success;
return
from_json(
$res
->content)->{server};
}
sub
get_servers_by_name {
my
(
$self
,
$name
) =
@_
;
my
$servers
=
$self
->get_servers(
detail
=> 1);
return
[
grep
{
$_
->{name} eq
$name
}
@$servers
];
}
sub
create_server {
my
(
$self
,
$data
) =
@_
;
croak
"invalid data"
unless
$data
and
'HASH'
eq
ref
$data
;
croak
"name is required"
unless
defined
$data
->{name};
croak
"flavorRef is required"
unless
defined
$data
->{flavorRef};
croak
"imageRef is required"
unless
defined
$data
->{imageRef};
my
$res
=
$self
->_post(
"/servers"
, {
server
=>
$data
});
return
from_json(
$res
->content)->{server};
}
sub
delete_server {
my
(
$self
,
$id
) =
@_
;
$self
->_delete(
$self
->_url(
"/servers/$id"
));
return
1;
}
sub
rebuild_server {
my
(
$self
,
$server
,
$data
) =
@_
;
croak
"server id is required"
unless
$server
;
croak
"invalid data"
unless
$data
and
'HASH'
eq
ref
$data
;
croak
"imageRef is required"
unless
$data
->{imageRef};
my
$res
=
$self
->_action(
$server
,
rebuild
=>
$data
);
return
from_json(
$res
->content)->{server};
}
sub
resize_server {
my
(
$self
,
$server
,
$data
) =
@_
;
croak
"server id is required"
unless
$server
;
croak
"invalid data"
unless
$data
and
'HASH'
eq
ref
$data
;
croak
"flavorRef is required"
unless
$data
->{flavorRef};
my
$res
=
$self
->_action(
$server
,
resize
=>
$data
);
return
1;
}
sub
reboot_server {
my
(
$self
,
$server
,
$data
) =
@_
;
croak
"server id is required"
unless
$server
;
croak
"invalid data"
unless
$data
and
'HASH'
eq
ref
$data
;
croak
"reboot type is required"
unless
$data
->{type};
my
$res
=
$self
->_action(
$server
,
reboot
=>
$data
);
return
1;
}
sub
set_password {
my
(
$self
,
$server
,
$password
) =
@_
;
croak
"server id is required"
unless
$server
;
croak
"password id is required"
unless
defined
$password
;
my
$res
=
$self
->_action(
$server
,
changePassword
=> {
adminPass
=>
$password
});
return
1;
}
sub
get_vnc_console {
my
(
$self
,
$server
,
$type
) =
@_
;
$type
||=
"novnc"
;
croak
"server id is required"
unless
$server
;
my
$res
=
$self
->_action(
$server
,
"os-getVNCConsole"
=> {
type
=>
$type
});
return
from_json(
$res
->content)->{console};
}
sub
get_networks {
my
(
$self
,
%params
) =
@_
;
my
$q
= _get_query(
%params
);
my
$res
=
$self
->_get(
$self
->_url(
"/os-tenant-networks"
,
$params
{detail},
$q
));
return
from_json(
$res
->content)->{networks};
}
sub
get_images {
my
(
$self
,
%params
) =
@_
;
my
$q
= _get_query(
%params
);
my
$res
=
$self
->_get(
$self
->_url(
"/images"
,
$params
{detail},
$q
));
return
from_json(
$res
->content)->{images};
}
sub
get_image {
my
(
$self
,
$id
) =
@_
;
my
$res
=
$self
->_get(
$self
->_url(
"/images/$id"
));
return
undef
unless
$res
->is_success;
return
from_json(
$res
->content)->{image};
}
sub
create_image {
my
(
$self
,
$server
,
$data
) =
@_
;
croak
"server id is required"
unless
defined
$server
;
croak
"invalid data"
unless
$data
and
'HASH'
eq
ref
$data
;
croak
"name is required"
unless
defined
$data
->{name};
my
$res
=
$self
->_action(
$server
,
createImage
=>
$data
);
return
1;
}
sub
delete_image {
my
(
$self
,
$id
) =
@_
;
$self
->_delete(
$self
->_url(
"/images/$id"
));
return
1;
}
sub
get_flavors {
my
(
$self
,
%params
) =
@_
;
my
$q
= _get_query(
%params
);
my
$res
=
$self
->_get(
$self
->_url(
'/flavors'
,
$params
{detail},
$q
));
return
from_json(
$res
->content)->{flavors};
}
sub
get_flavor {
my
(
$self
,
$id
) =
@_
;
my
$res
=
$self
->_get(
$self
->_url(
"/flavors/$id"
));
return
undef
unless
$res
->is_success;
return
from_json(
$res
->content)->{flavor};
}
sub
_url {
my
(
$self
,
$path
,
$is_detail
,
$query
) =
@_
;
my
$url
=
$self
->base_url .
$path
;
$url
.=
'/detail'
if
$is_detail
;
$url
.=
$query
if
$query
;
return
$url
;
}
sub
_get {
my
(
$self
,
$url
) =
@_
;
return
$self
->_agent->get(
$url
);
}
sub
_post {
my
(
$self
,
$url
,
$data
) =
@_
;
return
$self
->_agent->post(
$self
->_url(
$url
),
content_type
=>
'application/json'
,
content
=> to_json(
$data
),
);
}
sub
_delete {
my
(
$self
,
$url
) =
@_
;
my
$req
= HTTP::Request->new(
DELETE
=>
$url
);
return
$self
->_agent->request(
$req
);
}
sub
_action {
my
(
$self
,
$server
,
$action
,
$data
) =
@_
;
return
$self
->_post(
"/servers/$server/action"
, {
$action
=>
$data
});
}
sub
_check_res {
my
(
$res
) =
@_
;
die
$res
->status_line .
"\n"
.
$res
->content
if
!
$res
->is_success and
$res
->code != 404;
return
1;
}
around
qw( _get _post _delete )
=>
sub
{
my
$orig
=
shift
;
my
$self
=
shift
;
my
$res
=
$self
->
$orig
(
@_
);
_check_res(
$res
);
return
$res
;
};
1;