├── pve-manager └── js │ └── pvemanagerlib.js.patch ├── README └── perl5 ├── PVE └── Storage │ ├── ZFSPlugin.pm.patch │ └── LunCmd │ └── FreeNAS.pm └── REST └── Client.pm /pve-manager/js/pvemanagerlib.js.patch: -------------------------------------------------------------------------------- 1 | --- pvemanagerlib.js 2017-05-17 14:40:41.495308664 +0200 2 | +++ pvemanagerlib.js 2017-05-17 14:41:17.439945082 +0200 3 | @@ -7258,7 +7258,8 @@ 4 | comboItems: [ 5 | ['comstar', 'Comstar'], 6 | [ 'istgt', 'istgt'], 7 | - [ 'iet', 'IET'] 8 | + [ 'iet', 'IET'], 9 | + [ 'freenas', 'FreeNAS'] 10 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | patch files: 2 | /usr/share/pve-manager/js/pvemanagerlib.js 3 | /usr/share/perl5/PVE/Storage/ZFSPlugin.pm 4 | 5 | copy 6 | /usr/share/perl5/REST 7 | /usr/share/perl5/PVE/Storage/LunCmd/FreeNAS.pm 8 | 9 | UPDATE FreeNAS username and password in FreeNAS.pm 10 | 11 | 12 | in /usr/bin/pvedaemon remove -T from perl 13 | 14 | systemctl restart pvedaemon 15 | 16 | -------------------------------------------------------------------------------- /perl5/PVE/Storage/ZFSPlugin.pm.patch: -------------------------------------------------------------------------------- 1 | --- mountpoint/PVE/Storage/ZFSPlugin.pm 2017-05-17 15:19:32.000000000 +0200 2 | +++ mountpoint/PVE/Storage/ZFSPlugin.pm 2017-05-17 15:24:07.000000000 +0200 3 | @@ -12,6 +12,7 @@ 4 | use PVE::Storage::LunCmd::Comstar; 5 | use PVE::Storage::LunCmd::Istgt; 6 | use PVE::Storage::LunCmd::Iet; 7 | +use PVE::Storage::LunCmd::FreeNAS; 8 | 9 | 10 | my @ssh_opts = ('-o', 'BatchMode=yes'); 11 | @@ -31,7 +32,7 @@ 12 | my $zfs_unknown_scsi_provider = sub { 13 | my ($provider) = @_; 14 | 15 | - die "$provider: unknown iscsi provider. Available [comstar, istgt, iet]"; 16 | + die "$provider: unknown iscsi provider. Available [comstar, istgt, iet, freenas]"; 17 | }; 18 | 19 | my $zfs_get_base = sub { 20 | @@ -43,6 +44,8 @@ 21 | return PVE::Storage::LunCmd::Istgt::get_base; 22 | } elsif ($scfg->{iscsiprovider} eq 'iet') { 23 | return PVE::Storage::LunCmd::Iet::get_base; 24 | + } elsif ($scfg->{iscsiprovider} eq 'freenas') { 25 | + return PVE::Storage::LunCmd::FreeNAS::get_base; 26 | } else { 27 | $zfs_unknown_scsi_provider->($scfg->{iscsiprovider}); 28 | } 29 | @@ -63,6 +66,8 @@ 30 | $msg = PVE::Storage::LunCmd::Istgt::run_lun_command($scfg, $timeout, $method, @params); 31 | } elsif ($scfg->{iscsiprovider} eq 'iet') { 32 | $msg = PVE::Storage::LunCmd::Iet::run_lun_command($scfg, $timeout, $method, @params); 33 | + } elsif ($scfg->{iscsiprovider} eq 'freenas') { 34 | + $msg = PVE::Storage::LunCmd::FreeNAS::run_lun_command($scfg, $timeout, $method, @params); 35 | } else { 36 | $zfs_unknown_scsi_provider->($scfg->{iscsiprovider}); 37 | } 38 | -------------------------------------------------------------------------------- /perl5/PVE/Storage/LunCmd/FreeNAS.pm: -------------------------------------------------------------------------------- 1 | package PVE::Storage::LunCmd::FreeNAS; 2 | 3 | use strict; 4 | use warnings; 5 | use Data::Dumper; 6 | use PVE::SafeSyslog; 7 | 8 | use REST::Client; 9 | use MIME::Base64; 10 | use JSON; 11 | 12 | my $MAX_LUNS = 255; 13 | 14 | sub get_base { return '/dev/zvol'; } 15 | 16 | sub run_lun_command { 17 | my ($scfg, $timeout, $method, @params) = @_; 18 | 19 | # TODO : Move configuration of the storage 20 | if( ! defined( $scfg->{'freenas_user'} ) ) { 21 | $scfg->{'freenas_user'} = 'root'; 22 | $scfg->{'freenas_password'} = '*** password ***'; 23 | } 24 | 25 | syslog("info","FreeNAS::lun_command : $method(@params)"); 26 | 27 | if( $method eq "create_lu" ) { return run_create_lu($scfg,$timeout,$method,@params); } 28 | if( $method eq "delete_lu" ) { return run_delete_lu($scfg,$timeout,$method,@params); } 29 | if( $method eq "import_lu" ) { return run_create_lu($scfg,$timeout,$method,@params); } 30 | if( $method eq "modify_lu" ) { return run_modify_lu($scfg,$timeout,$method,@params); } 31 | if( $method eq "add_view" ) { return run_add_view($scfg,$timeout,$method,@params); } 32 | if( $method eq "list_view" ) { return run_list_view($scfg,$timeout,$method, @params); } 33 | if( $method eq "list_lu" ) { return run_list_lu($scfg,$timeout,$method,"name", @params); } 34 | 35 | syslog("error","FreeNAS::lun_command : unknown method $method"); 36 | return undef; 37 | } 38 | 39 | sub run_add_view { return ''; } 40 | 41 | # a modify_lu occur by example on a zvol resize. we just need to destroy and recreate the lun with the same zvol. 42 | # Be careful, the first param is the new size of the zvol, we must shift params 43 | sub run_modify_lu { 44 | my ($scfg, $timeout, $method, @params) = @_; 45 | shift(@params); 46 | run_delete_lu($scfg,$timeout,$method,@params); 47 | return run_create_lu($scfg,$timeout,$method,@params); 48 | } 49 | 50 | sub run_list_view { 51 | my ($scfg, $timeout, $method, @params) = @_; 52 | return run_list_lu($scfg,$timeout,$method,"lun-id", @params); 53 | } 54 | 55 | sub run_list_lu { 56 | my ($scfg, $timeout, $method, $result_value_type ,@params) = @_; 57 | my $object = $params[0]; 58 | my $result = undef; 59 | 60 | my $luns = freenas_list_lu($scfg); 61 | foreach my $lun ( @$luns ) { 62 | if ($lun->{'iscsi_target_extent_path'} =~ /^$object$/) { 63 | $result = $result_value_type eq "lun-id" ? $lun->{'iscsi_lunid'} : $lun->{'iscsi_target_extent_path'}; 64 | syslog("info","FreeNAS::list_lu($object):$result_value_type : lun found $result"); 65 | last; 66 | } 67 | } 68 | if( !defined($result) ) { 69 | syslog("info","FreeNAS::list_lu($object):$result_value_type : lun not found"); 70 | } 71 | 72 | return $result; 73 | } 74 | 75 | sub run_create_lu { 76 | my ($scfg, $timeout, $method, @params) = @_; 77 | 78 | my $lun_path = $params[0]; 79 | my $lun_id = freenas_get_first_available_lunid($scfg); 80 | 81 | die "Maximum number of LUNs per target is $MAX_LUNS" if scalar $lun_id >= $MAX_LUNS; 82 | die "$params[0]: LUN $lun_path exists" if defined(run_list_lu($scfg,$timeout,$method,"name", @params)); 83 | 84 | my $target_id = freenas_get_targetid($scfg); 85 | die "Unable to find the target id for $scfg->{target}" if !defined($target_id); 86 | 87 | # Create the extent 88 | my $extent = freenas_iscsi_create_extent($scfg, $lun_path); 89 | 90 | # Associate the new extent to the target 91 | my $link = freenas_iscsi_create_target_to_extent($scfg , $target_id , $extent->{'id'} , $lun_id ); 92 | 93 | if (defined($link) ) { 94 | syslog("info","FreeNAS::create_lu(lun_path=$lun_path, lun_id=$lun_id) : sucessfull"); 95 | } else { 96 | die "Unable to create lun $lun_path"; 97 | } 98 | 99 | return ""; 100 | } 101 | 102 | sub run_delete_lu { 103 | my ($scfg, $timeout, $method, @params) = @_; 104 | 105 | my $lun_path = $params[0]; 106 | my $luns = freenas_list_lu($scfg); 107 | my $lun = undef; 108 | my $link = undef; 109 | 110 | foreach my $item ( @$luns ) { 111 | if( $item->{'iscsi_target_extent_path'} =~ /^$lun_path$/ ) { 112 | $lun = $item; 113 | last; 114 | } 115 | } 116 | 117 | die "Unable to find the lun $lun_path for $scfg->{target}" if !defined($lun); 118 | 119 | my $target_id = freenas_get_targetid($scfg); 120 | die "Unable to find the target id for $scfg->{target}" if !defined($target_id); 121 | 122 | # find the target to extent 123 | my $target2extents = freenas_iscsi_get_target_to_extent($scfg); 124 | 125 | foreach my $item ( @$target2extents ) { 126 | if( $item->{'iscsi_target'} == $target_id && 127 | $item->{'iscsi_lunid'} == $lun->{'iscsi_lunid'} && 128 | $item->{'iscsi_extent'} == $lun->{'id'} ) { 129 | 130 | $link = $item; 131 | last; 132 | } 133 | } 134 | die "Unable to find the link for the lun $lun_path for $scfg->{target}" if !defined($link); 135 | 136 | # Remove the link 137 | my $remove_link = freenas_iscsi_remove_target_to_extent($scfg,$link->{'id'}); 138 | 139 | # Remove the extent 140 | my $remove_extent = freenas_iscsi_remove_extent($scfg,$lun->{'id'}); 141 | 142 | if( $remove_link == 1 && $remove_extent == 1 ) { 143 | syslog("info","FreeNAS::delete_lu(lun_path=$lun_path) : sucessfull"); 144 | } else { 145 | die "Unable to delete lun $lun_path"; 146 | } 147 | 148 | return ""; 149 | } 150 | 151 | 152 | ### FREENAS API CALLING ### 153 | 154 | sub freenas_api_call { 155 | my ($scfg, $method, $path, $data) = @_; 156 | my $client = undef; 157 | 158 | $client = REST::Client->new(); 159 | $client->setHost('http://'. $scfg->{portal} ); 160 | $client->addHeader('Content-Type' , 'application/json' ); 161 | $client->addHeader('Authorization' , 'Basic ' . encode_base64( $scfg->{freenas_user} . ':' . $scfg->{freenas_password} ) ); 162 | 163 | if ($method eq 'GET') { $client->GET($path); } 164 | if ($method eq 'DELETE') { $client->DELETE($path); } 165 | if ($method eq 'POST') { $client->POST($path, encode_json($data) ); } 166 | 167 | return $client 168 | } 169 | 170 | sub freenas_api_log_error { 171 | my ($client, $method) = @_; 172 | syslog("info","[ERROR]FreeNAS::API::" . $method . " : Response code: ".$client->responseCode()); 173 | syslog("info","[ERROR]FreeNAS::API::" . $method . " : Response content: ".$client->responseContent()); 174 | return 1; 175 | } 176 | 177 | sub freenas_iscsi_get_globalconfiguration { 178 | my ($scfg) = @_; 179 | my $client = freenas_api_call($scfg,'GET',"/api/v1.0/services/iscsi/globalconfiguration/",undef); 180 | my $code = $client->responseCode(); 181 | 182 | if ($code == 200) { 183 | my $result = decode_json($client->responseContent()); 184 | syslog("info","FreeNAS::API::get_globalconfig : target_basename=". $result->{'iscsi_basename'}); 185 | return $result; 186 | } else { 187 | freenas_api_log_error($client, "get_globalconfig"); 188 | return undef; 189 | } 190 | } 191 | 192 | # Returns a list of all extents. 193 | # http://api.freenas.org/resources/iscsi/index.html#get--api-v1.0-services-iscsi-extent- 194 | 195 | sub freenas_iscsi_get_extent { 196 | my ($scfg) = @_; 197 | my $client = freenas_api_call($scfg,'GET',"/api/v1.0/services/iscsi/extent/?limit=0",undef); 198 | 199 | my $code = $client->responseCode(); 200 | if ($code == 200) { 201 | my $result = decode_json($client->responseContent()); 202 | syslog("info","FreeNAS::API::get_extent : sucessfull"); 203 | return $result; 204 | } else { 205 | freenas_api_log_error($client, "get_extent"); 206 | return undef; 207 | } 208 | } 209 | 210 | # Create an extent on FreeNas 211 | # http://api.freenas.org/resources/iscsi/index.html#create-resource 212 | # Parameters: 213 | # - target config (scfg) 214 | # - lun_path 215 | 216 | sub freenas_iscsi_create_extent { 217 | my ($scfg, $lun_path) = @_; 218 | 219 | my $name = $lun_path; 220 | $name =~ s/^.*\///; # all from last / 221 | $name = $scfg->{'pool'} . '/' . $name; 222 | 223 | my $device = $lun_path; 224 | $device =~ s/^\/dev\///; # strip /dev/ 225 | 226 | my $request = { 227 | "iscsi_target_extent_type" => "Disk", 228 | "iscsi_target_extent_name" => $name, 229 | "iscsi_target_extent_disk" => $device, 230 | }; 231 | 232 | my $client = freenas_api_call($scfg, 'POST', "/api/v1.0/services/iscsi/extent/", $request); 233 | my $code = $client->responseCode(); 234 | if ($code == 201) { 235 | my $result = decode_json($client->responseContent()); 236 | syslog("info","FreeNAS::API::create_extent(lun_path=". $result->{'iscsi_target_extent_path'} . ") : sucessfull"); 237 | return $result; 238 | } else { 239 | freenas_api_log_error($client, "create_extent"); 240 | return undef; 241 | } 242 | } 243 | 244 | # Remove an extent by it's id 245 | # http://api.freenas.org/resources/iscsi/index.html#delete-resource 246 | # Parameters: 247 | # - scfg 248 | # - extent_id 249 | 250 | sub freenas_iscsi_remove_extent { 251 | my ($scfg,$extent_id) = @_; 252 | 253 | my $client = freenas_api_call($scfg, 'DELETE', "/api/v1.0/services/iscsi/extent/$extent_id/", undef); 254 | my $code = $client->responseCode(); 255 | if ($code == 204) { 256 | syslog("info","FreeNAS::API::remove_extent(extent_id=$extent_id) : sucessfull"); 257 | return 1; 258 | } else { 259 | freenas_api_log_error($client, "remove_extent"); 260 | return 0; 261 | } 262 | } 263 | 264 | # Returns a list of all targets 265 | # http://api.freenas.org/resources/iscsi/index.html#get--api-v1.0-services-iscsi-target- 266 | 267 | sub freenas_iscsi_get_target { 268 | my ($scfg) = @_; 269 | 270 | my $client = freenas_api_call($scfg,'GET',"/api/v1.0/services/iscsi/target/?limit=0",undef); 271 | my $code = $client->responseCode(); 272 | if ($code == 200) { 273 | my $result = decode_json($client->responseContent()); 274 | syslog("info","FreeNAS::API::get_target() : sucessfull"); 275 | return $result; 276 | } else { 277 | freenas_api_log_error($client, "get_target"); 278 | return undef; 279 | } 280 | } 281 | 282 | # Returns a list of associated extents to targets 283 | # http://api.freenas.org/resources/iscsi/index.html#get--api-v1.0-services-iscsi-targettoextent- 284 | 285 | sub freenas_iscsi_get_target_to_extent { 286 | my ($scfg) = @_; 287 | 288 | my $client = freenas_api_call($scfg,'GET',"/api/v1.0/services/iscsi/targettoextent/?limit=0",undef); 289 | my $code = $client->responseCode(); 290 | if ($code == 200) { 291 | my $result = decode_json($client->responseContent()); 292 | syslog("info","FreeNAS::API::get_target_to_extent() : sucessfull"); 293 | return $result; 294 | } else { 295 | freenas_api_log_error($client, "get_target_to_extent"); 296 | return undef; 297 | } 298 | } 299 | 300 | # Associate a FreeNas extent to a FreeNas Target 301 | # http://api.freenas.org/resources/iscsi/index.html#post--api-v1.0-services-iscsi-targettoextent- 302 | # Parameters: 303 | # - target config (scfg) 304 | # - FreeNas Target ID 305 | # - FreeNas Extent ID 306 | # - Lun ID 307 | 308 | sub freenas_iscsi_create_target_to_extent { 309 | my ($scfg,$target_id,$extent_id,$lun_id) = @_; 310 | 311 | my $request = { 312 | "iscsi_target" => $target_id, 313 | "iscsi_extent" => $extent_id, 314 | "iscsi_lunid" => $lun_id 315 | }; 316 | 317 | my $client = freenas_api_call($scfg, 'POST', "/api/v1.0/services/iscsi/targettoextent/", $request); 318 | my $code = $client->responseCode(); 319 | if ($code == 201) { 320 | my $result = decode_json($client->responseContent()); 321 | syslog("info","FreeNAS::API::create_target_to_extent(target_id=$target_id, extent_id=$extent_id, lun_id=$lun_id) : sucessfull"); 322 | return $result; 323 | } else { 324 | freenas_api_log_error($client, "create_target_to_extent"); 325 | return undef; 326 | } 327 | } 328 | 329 | # Remove a Target to extent by it's id 330 | # http://api.freenas.org/resources/iscsi/index.html#delete--api-v1.0-services-iscsi-targettoextent-(int-id)- 331 | # Parameters: 332 | # - scfg 333 | # - link_id 334 | 335 | sub freenas_iscsi_remove_target_to_extent { 336 | my ($scfg,$link_id) = @_; 337 | 338 | my $client = freenas_api_call($scfg, 'DELETE', "/api/v1.0/services/iscsi/targettoextent/$link_id/", undef); 339 | my $code = $client->responseCode(); 340 | if ($code == 204) { 341 | syslog("info","FreeNAS::API::remove_target_to_extent(link_id=$link_id) : sucessfull"); 342 | return 1; 343 | } else { 344 | freenas_api_log_error($client, "remove_target_to_extent"); 345 | return 0; 346 | } 347 | } 348 | 349 | # Returns all luns associated to the current target defined by $scfg->{target} 350 | # This method returns an array reference like "freenas_iscsi_get_extent" do 351 | # but with an additionnal hash entry "iscsi_lunid" retrieved from "freenas_iscsi_get_target_to_extent" 352 | # 353 | sub freenas_list_lu { 354 | my ($scfg) = @_; 355 | 356 | my $targets = freenas_iscsi_get_target($scfg); 357 | my $target_id = freenas_get_targetid($scfg); 358 | 359 | my @luns = (); 360 | 361 | if( defined($target_id) ) { 362 | my $target2extents = freenas_iscsi_get_target_to_extent($scfg); 363 | my $extents = freenas_iscsi_get_extent($scfg); 364 | 365 | foreach my $item ( @$target2extents ) { 366 | if( $item->{'iscsi_target'} == $target_id ) { 367 | foreach my $node ( @$extents ) { 368 | if( $node->{'id'} == $item->{'iscsi_extent'} ) { 369 | $node->{'iscsi_lunid'} .= $item->{'iscsi_lunid'}; 370 | push( @luns , $node ); 371 | } 372 | } 373 | } 374 | } 375 | } 376 | syslog("info","FreeNAS::API::freenas_list_lu : sucessfull"); 377 | return \@luns; 378 | } 379 | 380 | # Returns the first available "lunid" (in all targets namespaces) 381 | # 382 | sub freenas_get_first_available_lunid { 383 | my ($scfg) = @_; 384 | 385 | my $target_id = freenas_get_targetid($scfg); 386 | my $target2extents = freenas_iscsi_get_target_to_extent($scfg); 387 | my @luns = (); 388 | 389 | foreach my $item ( @$target2extents ) { 390 | push(@luns, $item->{'iscsi_lunid'}) if ($item->{'iscsi_target'} == $target_id); 391 | } 392 | 393 | my @sorted_luns = sort { $a <=> $b } @luns; 394 | my $lun_id = 0; 395 | 396 | # find the first hole, if not, give the +1 of the last lun 397 | foreach my $lun ( @sorted_luns ) { 398 | last if $lun != $lun_id; 399 | $lun_id = $lun_id + 1; 400 | } 401 | 402 | syslog("info","FreeNAS::API::freenas_get_first_available_lunid : return $lun_id"); 403 | return $lun_id; 404 | } 405 | 406 | # 407 | # Returns the target id on FreeNas of the currently configured target of this PVE storage 408 | # 409 | sub freenas_get_targetid { 410 | my ($scfg) = @_; 411 | 412 | my $global = freenas_iscsi_get_globalconfiguration($scfg); 413 | my $targets = freenas_iscsi_get_target($scfg); 414 | my $target_id = undef; 415 | 416 | foreach my $target ( @$targets ) { 417 | my $iqn = $global->{'iscsi_basename'} . ':' . $target->{'iscsi_target_name'}; 418 | if( $iqn eq $scfg->{target} ) { $target_id = $target->{'id'}; last } 419 | } 420 | 421 | return $target_id; 422 | } 423 | 424 | 425 | 1; 426 | -------------------------------------------------------------------------------- /perl5/REST/Client.pm: -------------------------------------------------------------------------------- 1 | package REST::Client; 2 | 3 | =head1 NAME 4 | 5 | REST::Client - A simple client for interacting with RESTful http/https resources 6 | 7 | =head1 SYNOPSIS 8 | 9 | use REST::Client; 10 | 11 | #The basic use case 12 | my $client = REST::Client->new(); 13 | $client->GET('http://example.com/dir/file.xml'); 14 | print $client->responseContent(); 15 | 16 | #A host can be set for convienience 17 | $client->setHost('http://example.com'); 18 | $client->PUT('/dir/file.xml', 'new content'); 19 | if( $client->responseCode() eq '200' ){ 20 | print "Updated\n"; 21 | } 22 | 23 | #custom request headers may be added 24 | $client->addHeader('CustomHeader', 'Value'); 25 | 26 | #response headers may be gathered 27 | print $client->responseHeader('ResponseHeader'); 28 | 29 | #X509 client authentication 30 | $client->setCert('/path/to/ssl.crt'); 31 | $client->setKey('/path/to/ssl.key'); 32 | 33 | #add a CA to verify server certificates 34 | $client->setCa('/path/to/ca.file'); 35 | 36 | #you may set a timeout on requests, in seconds 37 | $client->setTimeout(10); 38 | 39 | #options may be passed as well as set 40 | $client = REST::Client->new({ 41 | host => 'https://example.com', 42 | cert => '/path/to/ssl.crt', 43 | key => '/path/to/ssl.key', 44 | ca => '/path/to/ca.file', 45 | timeout => 10, 46 | }); 47 | $client->GET('/dir/file', {CustomHeader => 'Value'}); 48 | 49 | # Requests can be specificed directly as well 50 | $client->request('GET', '/dir/file', 'request body content', {CustomHeader => 'Value'}); 51 | 52 | # Requests can optionally automatically follow redirects and auth, defaults to 53 | # false 54 | $client->setFollow(1); 55 | 56 | #It is possible to access the L object REST::Client is using to 57 | #make requests, and set advanced options on it, for instance: 58 | $client->getUseragent()->proxy(['http'], 'http://proxy.example.com/'); 59 | 60 | # request responses can be written directly to a file 61 | $client->setContentFile( "FileName" ); 62 | 63 | # or call back method 64 | $client->setContentFile( \&callback_method ); 65 | # see LWP::UserAgent for how to define callback methods 66 | 67 | =head1 DESCRIPTION 68 | 69 | REST::Client provides a simple way to interact with HTTP RESTful resources. 70 | 71 | =cut 72 | 73 | =head1 METHODS 74 | 75 | =cut 76 | 77 | use strict; 78 | use warnings; 79 | use 5.008_000; 80 | 81 | use constant TRUE => 1; 82 | use constant FALSE => 0; 83 | 84 | our ($VERSION) = ('$Rev: 273 $' =~ /(\d+)/); 85 | 86 | use URI; 87 | use LWP::UserAgent; 88 | use Carp qw(croak carp); 89 | 90 | =head2 Construction and setup 91 | 92 | =head3 new ( [%$config] ) 93 | 94 | Construct a new REST::Client. Takes an optional hash or hash reference or 95 | config flags. Each config flag also has get/set accessors of the form 96 | getHost/setHost, getUseragent/setUseragent, etc. These can be called on the 97 | instantiated object to change or check values. 98 | 99 | The config flags are: 100 | 101 | =over 4 102 | 103 | =item host 104 | 105 | A default host that will be prepended to all requests. Allows you to just 106 | specify the path when making requests. 107 | 108 | The default is undef - you must include the host in your requests. 109 | 110 | =item timeout 111 | 112 | A timeout in seconds for requests made with the client. After the timeout the 113 | client will return a 500. 114 | 115 | The default is 5 minutes. 116 | 117 | =item cert 118 | 119 | The path to a X509 certificate file to be used for client authentication. 120 | 121 | The default is to not use a certificate/key pair. 122 | 123 | =item key 124 | 125 | The path to a X509 key file to be used for client authentication. 126 | 127 | The default is to not use a certificate/key pair. 128 | 129 | =item ca 130 | 131 | The path to a certificate authority file to be used to verify host 132 | certificates. 133 | 134 | The default is to not use a certificates authority. 135 | 136 | =item pkcs12 137 | 138 | The path to a PKCS12 certificate to be used for client authentication. 139 | 140 | =item pkcs12password 141 | 142 | The password for the PKCS12 certificate specified with 'pkcs12'. 143 | 144 | =item follow 145 | 146 | Boolean that determins whether REST::Client attempts to automatically follow 147 | redirects/authentication. 148 | 149 | The default is false. 150 | 151 | =item useragent 152 | 153 | An L object, ready to make http requests. 154 | 155 | REST::Client will provide a default for you if you do not set this. 156 | 157 | =back 158 | 159 | =cut 160 | 161 | sub new { 162 | my $class = shift; 163 | my $config; 164 | 165 | $class->_buildAccessors(); 166 | 167 | if(ref $_[0] eq 'HASH'){ 168 | $config = shift; 169 | }elsif(scalar @_ && scalar @_ % 2 == 0){ 170 | $config = {@_}; 171 | }else{ 172 | $config = {}; 173 | } 174 | 175 | my $self = bless({}, $class); 176 | $self->{'_config'} = $config; 177 | 178 | $self->_buildUseragent(); 179 | 180 | return $self; 181 | } 182 | 183 | =head3 addHeader ( $header_name, $value ) 184 | 185 | Add a custom header to any requests made by this client. 186 | 187 | =cut 188 | 189 | sub addHeader { 190 | my $self = shift; 191 | my $header = shift; 192 | my $value = shift; 193 | 194 | my $headers = $self->{'_headers'} || {}; 195 | $headers->{$header} = $value; 196 | $self->{'_headers'} = $headers; 197 | return; 198 | } 199 | 200 | =head3 buildQuery ( [...] ) 201 | 202 | A convienience wrapper around URI::query_form for building query strings from a 203 | variety of data structures. See L 204 | 205 | Returns a scalar query string for use in URLs. 206 | 207 | =cut 208 | 209 | sub buildQuery { 210 | my $self = shift; 211 | 212 | my $uri = URI->new(); 213 | $uri->query_form(@_); 214 | return $uri->as_string(); 215 | } 216 | 217 | 218 | 219 | =head2 Request Methods 220 | 221 | Each of these methods makes an HTTP request, sets the internal state of the 222 | object, and returns the object. 223 | 224 | They can be combined with the response methods, such as: 225 | 226 | print $client->GET('/search/?q=foobar')->responseContent(); 227 | 228 | =head3 GET ( $url, [%$headers] ) 229 | 230 | Preform an HTTP GET to the resource specified. Takes an optional hashref of custom request headers. 231 | 232 | =cut 233 | 234 | sub GET { 235 | my $self = shift; 236 | my $url = shift; 237 | my $headers = shift; 238 | return $self->request('GET', $url, undef, $headers); 239 | } 240 | 241 | =head3 PUT ($url, [$body_content, %$headers] ) 242 | 243 | Preform an HTTP PUT to the resource specified. Takes an optional body content and hashref of custom request headers. 244 | 245 | =cut 246 | 247 | sub PUT { 248 | my $self = shift; 249 | return $self->request('PUT', @_); 250 | } 251 | 252 | =head3 PATCH ( $url, [$body_content, %$headers] ) 253 | 254 | Preform an HTTP PATCH to the resource specified. Takes an optional body content and hashref of custom request headers. 255 | 256 | =cut 257 | 258 | sub PATCH { 259 | my $self = shift; 260 | return $self->request('PATCH', @_); 261 | } 262 | 263 | =head3 POST ( $url, [$body_content, %$headers] ) 264 | 265 | Preform an HTTP POST to the resource specified. Takes an optional body content and hashref of custom request headers. 266 | 267 | =cut 268 | 269 | sub POST { 270 | my $self = shift; 271 | return $self->request('POST', @_); 272 | } 273 | 274 | =head3 DELETE ( $url, [%$headers] ) 275 | 276 | Preform an HTTP DELETE to the resource specified. Takes an optional hashref of custom request headers. 277 | 278 | =cut 279 | 280 | sub DELETE { 281 | my $self = shift; 282 | my $url = shift; 283 | my $headers = shift; 284 | return $self->request('DELETE', $url, undef, $headers); 285 | } 286 | 287 | =head3 OPTIONS ( $url, [%$headers] ) 288 | 289 | Preform an HTTP OPTIONS to the resource specified. Takes an optional hashref of custom request headers. 290 | 291 | =cut 292 | 293 | sub OPTIONS { 294 | my $self = shift; 295 | my $url = shift; 296 | my $headers = shift; 297 | return $self->request('OPTIONS', $url, undef, $headers); 298 | } 299 | 300 | =head3 HEAD ( $url, [%$headers] ) 301 | 302 | Preform an HTTP HEAD to the resource specified. Takes an optional hashref of custom request headers. 303 | 304 | =cut 305 | 306 | sub HEAD { 307 | my $self = shift; 308 | my $url = shift; 309 | my $headers = shift; 310 | return $self->request('HEAD', $url, undef, $headers); 311 | } 312 | 313 | =head3 request ( $method, $url, [$body_content, %$headers] ) 314 | 315 | Issue a custom request, providing all possible values. 316 | 317 | =cut 318 | 319 | sub request { 320 | my $self = shift; 321 | my $method = shift; 322 | my $url = shift; 323 | my $content = shift; 324 | my $headers = shift; 325 | 326 | $self->{'_res'} = undef; 327 | $self->_buildUseragent(); 328 | 329 | 330 | #error check 331 | croak "REST::Client exception: First argument to request must be one of GET, PATCH, PUT, POST, DELETE, OPTIONS, HEAD" unless $method =~ /^(get|patch|put|post|delete|options|head)$/i; 332 | croak "REST::Client exception: Must provide a url to $method" unless $url; 333 | croak "REST::Client exception: headers must be presented as a hashref" if $headers && ref $headers ne 'HASH'; 334 | 335 | 336 | $url = $self->_prepareURL($url); 337 | 338 | my $ua = $self->getUseragent(); 339 | if(defined $self->getTimeout()){ 340 | $ua->timeout($self->getTimeout); 341 | }else{ 342 | $ua->timeout(300); 343 | } 344 | my $req = HTTP::Request->new( $method => $url ); 345 | 346 | #build headers 347 | if(defined $content && length($content)){ 348 | $req->content($content); 349 | $req->header('Content-Length', length($content)); 350 | }else{ 351 | $req->header('Content-Length', 0); 352 | } 353 | 354 | my $custom_headers = $self->{'_headers'} || {}; 355 | for my $header (keys %$custom_headers){ 356 | $req->header($header, $custom_headers->{$header}); 357 | } 358 | 359 | for my $header (keys %$headers){ 360 | $req->header($header, $headers->{$header}); 361 | } 362 | 363 | 364 | #prime LWP with ssl certfile if we have values 365 | if($self->getCert){ 366 | carp "REST::Client exception: Certs defined but not using https" unless $url =~ /^https/; 367 | croak "REST::Client exception: Cannot read cert and key file" unless -f $self->getCert && -f $self->getKey; 368 | 369 | $ua->ssl_opts(SSL_cert_file => $self->getCert); 370 | $ua->ssl_opts(SSL_key_file => $self->getKey); 371 | } 372 | 373 | #prime LWP with CA file if we have one 374 | if(my $ca = $self->getCa){ 375 | croak "REST::Client exception: Cannot read CA file" unless -f $ca; 376 | $ua->ssl_opts(SSL_ca_file => $ca); 377 | } 378 | 379 | #prime LWP with PKCS12 certificate if we have one 380 | if($self->getPkcs12){ 381 | carp "REST::Client exception: PKCS12 cert defined but not using https" unless $url =~ /^https/; 382 | croak "REST::Client exception: Cannot read PKCS12 cert" unless -f $self->getPkcs12; 383 | 384 | $ENV{HTTPS_PKCS12_FILE} = $self->getPkcs12; 385 | if($self->getPkcs12password){ 386 | $ENV{HTTPS_PKCS12_PASSWORD} = $self->getPkcs12password; 387 | } 388 | } 389 | 390 | my $res = $self->getFollow ? 391 | $ua->request( $req, $self->getContentFile ) : 392 | $ua->simple_request( $req, $self->getContentFile ); 393 | 394 | $self->{_res} = $res; 395 | 396 | return $self; 397 | } 398 | 399 | =head2 Response Methods 400 | 401 | Use these methods to gather information about the last requset 402 | performed. 403 | 404 | =head3 responseCode () 405 | 406 | Return the HTTP response code of the last request 407 | 408 | =cut 409 | 410 | sub responseCode { 411 | my $self = shift; 412 | return $self->{_res}->code; 413 | } 414 | 415 | =head3 responseContent () 416 | 417 | Return the response body content of the last request 418 | 419 | =cut 420 | 421 | sub responseContent { 422 | my $self = shift; 423 | return $self->{_res}->content; 424 | } 425 | 426 | =head3 responseHeaders() 427 | 428 | Returns a list of HTTP header names from the last response 429 | 430 | =cut 431 | 432 | sub responseHeaders { 433 | my $self = shift; 434 | return $self->{_res}->headers()->header_field_names(); 435 | } 436 | 437 | 438 | 439 | =head3 responseHeader ( $header ) 440 | 441 | Return a HTTP header from the last response 442 | 443 | =cut 444 | 445 | sub responseHeader { 446 | my $self = shift; 447 | my $header = shift; 448 | croak "REST::Client exception: no header provided to responseHeader" unless $header; 449 | return $self->{_res}->header($header); 450 | } 451 | 452 | =head3 responseXpath () 453 | 454 | A convienience wrapper that returns a L xpath context for the body content. Assumes the content is XML. 455 | 456 | =cut 457 | 458 | sub responseXpath { 459 | my $self = shift; 460 | 461 | require XML::LibXML; 462 | 463 | my $xml= XML::LibXML->new(); 464 | $xml->load_ext_dtd(0); 465 | 466 | if($self->responseHeader('Content-type') =~ /html/){ 467 | return XML::LibXML::XPathContext->new($xml->parse_html_string( $self->responseContent() )); 468 | }else{ 469 | return XML::LibXML::XPathContext->new($xml->parse_string( $self->responseContent() )); 470 | } 471 | } 472 | 473 | # Private methods 474 | 475 | sub _prepareURL { 476 | my $self = shift; 477 | my $url = shift; 478 | 479 | my $host = $self->getHost; 480 | if($host){ 481 | $url = '/'.$url unless $url =~ /^\//; 482 | $url = $host . $url; 483 | } 484 | unless($url =~ /^\w+:\/\//){ 485 | $url = ($self->getCert ? 'https://' : 'http://') . $url; 486 | } 487 | 488 | return $url; 489 | } 490 | 491 | sub _buildUseragent { 492 | my $self = shift; 493 | 494 | return if $self->getUseragent(); 495 | 496 | my $ua = LWP::UserAgent->new; 497 | $ua->agent("REST::Client/$VERSION"); 498 | $self->setUseragent($ua); 499 | 500 | return; 501 | } 502 | 503 | sub _buildAccessors { 504 | my $self = shift; 505 | 506 | return if $self->can('setHost'); 507 | 508 | my @attributes = qw(Host Key Cert Ca Timeout Follow Useragent Pkcs12 Pkcs12password ContentFile); 509 | 510 | for my $attribute (@attributes){ 511 | my $set_method = " 512 | sub { 513 | my \$self = shift; 514 | \$self->{'_config'}{lc('$attribute')} = shift; 515 | return \$self->{'_config'}{lc('$attribute')}; 516 | }"; 517 | 518 | my $get_method = " 519 | sub { 520 | my \$self = shift; 521 | return \$self->{'_config'}{lc('$attribute')}; 522 | }"; 523 | 524 | 525 | { 526 | no strict 'refs'; 527 | *{'REST::Client::set'.$attribute} = eval $set_method ; 528 | *{'REST::Client::get'.$attribute} = eval $get_method ; 529 | } 530 | 531 | } 532 | 533 | return; 534 | } 535 | 536 | 1; 537 | 538 | 539 | =head1 TODO 540 | 541 | Caching, content-type negotiation, readable handles for body content. 542 | 543 | =head1 AUTHOR 544 | 545 | Miles Crawford, Emcrawfor@cpan.orgE 546 | 547 | =head1 COPYRIGHT 548 | 549 | Copyright 2008 - 2010 by Miles Crawford 550 | 551 | This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. 552 | 553 | =cut 554 | --------------------------------------------------------------------------------