FS/FS/part_export/sipwise.pm

   1 package FS::part_export::sipwise;
   2
   3 use base qw( FS::part_export );
   4 use strict;
   5
   6 use FS::Record qw(qsearch qsearchs dbh);
   7 use Tie::IxHash;
   8 use IO::Socket::SSL;
   9 use LWP::UserAgent;
  10 use URI;
  11 use Cpanel::JSON::XS;
  12 use HTTP::Request::Common qw(GET POST PUT DELETE);
  13 use FS::Misc::DateTime qw(parse_datetime);
  14 use DateTime;
  15 use Number::Phone;
  16 use Try::Tiny;
  17
  18 our $me = '[sipwise]';
  19 our $DEBUG = 0;
  20
  21 tie my %options, 'Tie::IxHash',
  22   'port'            => { label => 'Port' },
  23   'username'        => { label => 'API username', },
  24   'password'        => { label => 'API password', },
  25   'debug'           => { label => 'Enable debugging', type => 'checkbox', value => 1 },
  26   'billing_profile' => {
  27     label             => 'Billing profile handle',
  28     default           => 'default',
  29   },
  30   'subscriber_profile_set' => {
  31     label             => 'Subscriber profile set name (optional)',
  32   },
  33   'reseller_id'     => { label => 'Reseller ID' },
  34   'ssl_no_verify'   => { label => 'Skip SSL certificate validation',
  35                          type  => 'checkbox',
  36                        },
  37 ;
  38
  39 tie my %roles, 'Tie::IxHash',
  40   'subscriber'    => {  label     => 'Subscriber',
  41                         svcdb     => 'svc_acct',
  42                         multiple  => 1,
  43                      },
  44   'did'           => {  label     => 'DID',
  45                         svcdb     => 'svc_phone',
  46                         multiple  => 1,
  47                      },
  48 ;
  49
  50 our %info = (
  51   'svc'      => [qw( svc_acct svc_phone )],
  52   'desc'     => 'Provision to a Sipwise sip:provider server',
  53   'options'  => \%options,
  54   'roles'    => \%roles,
  55   'notes'    => <<'END'
  56 <P>Export to a <b>sip:provider</b> server.</P>
  57 <P>This requires two service definitions to be configured on the same package:
  58   <OL>
  59     <LI>An account service for a SIP client account ("subscriber"). The
  60     <i>username</i> will be the SIP username. The <i>domsvc</i> should point
  61     to a domain service to use as the SIP domain name.</LI>
  62     <LI>A phone service for a DID. The <i>phonenum</i> here will be a PSTN
  63     number. The <i>forward_svcnum</i> field should be set to the account that
  64     will receive calls at this number.
  65   </OL>
  66 </P>
  67 END
  68 );
  69
  70 sub export_insert {
  71   my($self, $svc_x) = (shift, shift);
  72
  73   local $SIG{__DIE__};
  74   my $error;
  75   my $role = $self->svc_role($svc_x);
  76   if ( $role eq 'subscriber' ) {
  77
  78     try { $self->insert_subscriber($svc_x) }
  79     catch { $error = $_ };
  80
  81   } elsif ( $role eq 'did' ) {
  82
  83     try { $self->export_did($svc_x) }
  84     catch { $error = $_ };
  85
  86   }
  87   return "$me $error" if $error;
  88   '';
  89 }
  90
  91 sub export_replace {
  92   my ($self, $svc_new, $svc_old) = @_;
  93   local $SIG{__DIE__};
  94
  95   my $role = $self->svc_role($svc_new);
  96
  97   my $error;
  98   if ( $role eq 'subscriber' ) {
  99
 100     try { $self->replace_subscriber($svc_new, $svc_old) }
 101     catch { $error = $_ };
 102
 103   } elsif ( $role eq 'did' ) {
 104
 105     try { $self->export_did($svc_new, $svc_old) }
 106     catch { $error = $_ };
 107
 108   }
 109   return "$me $error" if $error;
 110   '';
 111 }
 112
 113 sub export_delete {
 114   my ($self, $svc_x) = (shift, shift);
 115   local $SIG{__DIE__};
 116
 117   my $role = $self->svc_role($svc_x);
 118   my $error;
 119
 120   if ( $role eq 'subscriber' ) {
 121
 122     # no need to remove DIDs from it, just drop the subscriber record
 123     try { $self->delete_subscriber($svc_x) }
 124     catch { $error = $_ };
 125
 126   } elsif ( $role eq 'did' ) {
 127
 128     try { $self->export_did($svc_x) }
 129     catch { $error = $_ };
 130
 131   }
 132   return "$me $error" if $error;
 133   '';
 134 }
 135
 136 # logic to set subscribers to locked/active is in replace_subscriber
 137
 138 sub export_suspend {
 139   my $self = shift;
 140   my $svc_x = shift;
 141   my $role = $self->svc_role($svc_x);
 142   my $error;
 143   if ( $role eq 'subscriber' ) {
 144     try { $self->replace_subscriber($svc_x, $svc_x) }
 145     catch { $error = $_ };
 146   }
 147   return "$me $error" if $error;
 148   '';
 149 }
 150
 151 sub export_unsuspend {
 152   my $self = shift;
 153   my $svc_x = shift;
 154   my $role = $self->svc_role($svc_x);
 155   my $error;
 156   if ( $role eq 'subscriber' ) {
 157     $svc_x->set('unsuspended', 1);
 158     try { $self->replace_subscriber($svc_x, $svc_x) }
 159     catch { $error = $_ };
 160   }
 161   return "$me $error" if $error;
 162   '';
 163 }
 164
 165 #############
 166 # CUSTOMERS #
 167 #############
 168
 169 =item get_customer SERVICE
 170
 171 Returns the Sipwise customer record that should belong to SERVICE. This is
 172 based on the pkgnum field.
 173
 174 =cut
 175
 176 sub get_customer {
 177   my $self = shift;
 178   my $svc = shift;
 179   my $pkgnum = $svc->cust_svc->pkgnum;
 180   my $custid = "cust_pkg#$pkgnum";
 181
 182   my @cust = $self->api_query('customers', [ external_id => $custid ]);
 183   warn "$me multiple customers for external_id $custid.\n" if scalar(@cust) > 1;
 184   $cust[0];
 185 }
 186
 187 sub find_or_create_customer {
 188   my $self = shift;
 189   my $svc = shift;
 190   my $cust = $self->get_customer($svc);
 191   return $cust if $cust;
 192
 193   my $cust_pkg = $svc->cust_svc->cust_pkg;
 194   my $cust_main = $cust_pkg->cust_main;
 195   my $cust_location = $cust_pkg->cust_location;
 196   my ($email) = $cust_main->invoicing_list_emailonly;
 197   die "Customer contact email required\n" if !$email;
 198   my $custid = 'cust_pkg#' . $cust_pkg->pkgnum;
 199
 200   # find the billing profile
 201   my ($billing_profile) = $self->api_query('billingprofiles',
 202     [
 203       'handle'        => $self->option('billing_profile'),
 204       'reseller_id'   => $self->option('reseller_id'),
 205     ]
 206   );
 207   if (!$billing_profile) {
 208     die "can't find billing profile '". $self->option('billing_profile') . "'\n";
 209   }
 210   my $bpid = $billing_profile->{id};
 211
 212   # contacts unfortunately have no searchable external_id or other field
 213   # like that, so we can't go location -> package -> service
 214   my $contact = $self->api_create('customercontacts',
 215     {
 216       'city'          => $cust_location->city,
 217       'company'       => $cust_main->company,
 218       'country'       => $cust_location->country,
 219       'email'         => $email,
 220       'faxnumber'     => $cust_main->fax,
 221       'firstname'     => $cust_main->first,
 222       'lastname'      => $cust_main->last,
 223       'mobilenumber'  => $cust_main->mobile,
 224       'phonenumber'   => ($cust_main->daytime || $cust_main->night),
 225       'postcode'      => $cust_location->zip,
 226       'reseller_id'   => $self->option('reseller_id'),
 227       'street'        => $cust_location->address1,
 228     }
 229   );
 230
 231   $cust = $self->api_create('customers',
 232     {
 233       'status'      => 'active',
 234       'type'        => 'sipaccount',
 235       'contact_id'  => $contact->{id},
 236       'external_id' => $custid,
 237       'billing_profile_id' => $bpid,
 238     }
 239   );
 240
 241   $cust;
 242 }
 243
 244 ###########
 245 # DOMAINS #
 246 ###########
 247
 248 =item find_or_create_domain DOMAIN
 249
 250 Returns the record for the domain object named DOMAIN. If necessary, will
 251 create it first.
 252
 253 =cut
 254
 255 sub find_or_create_domain {
 256   my $self = shift;
 257   my $domainname = shift;
 258   my ($domain) = $self->api_query('domains', [ 'domain' => $domainname ]);
 259   return $domain if $domain;
 260
 261   $self->api_create('domains',
 262     {
 263       'domain'        => $domainname,
 264       'reseller_id'   => $self->option('reseller_id'),
 265     }
 266   );
 267 }
 268
 269 ########
 270 # DIDS #
 271 ########
 272
 273 =item acct_for_did SVC_PHONE
 274
 275 Returns the subscriber svc_acct linked to SVC_PHONE.
 276
 277 =cut
 278
 279 sub acct_for_did {
 280   my $self = shift;
 281   my $svc_phone = shift;
 282   my $svcnum = $svc_phone->forward_svcnum or return;
 283   my $svc_acct = FS::svc_acct->by_key($svcnum) or return;
 284   $self->svc_role($svc_acct) eq 'subscriber' or return;
 285   $svc_acct;
 286 }
 287
 288 =item export_did NEW, OLD
 289
 290 Refreshes the subscriber information for the service the DID was linked to
 291 previously, and the one it's linked to now.
 292
 293 =cut
 294
 295 sub export_did {
 296   my $self = shift;
 297   my ($new, $old) = @_;
 298   if ( $old and $new->forward_svcnum ne $old->forward_svcnum ) {
 299     my $old_svc_acct = $self->acct_for_did($old);
 300     $self->replace_subscriber( $old_svc_acct ) if $old_svc_acct;
 301   }
 302   my $new_svc_acct = $self->acct_for_did($new);
 303   $self->replace_subscriber( $new_svc_acct ) if $new_svc_acct;
 304 }
 305
 306 ###############
 307 # SUBSCRIBERS #
 308 ###############
 309
 310 =item get_subscriber SVC
 311
 312 Gets the subscriber record for SVC, if there is one.
 313
 314 =cut
 315
 316 sub get_subscriber {
 317   my $self = shift;
 318   my $svc = shift;
 319
 320   my $svcnum = $svc->svcnum;
 321   my $svcid = "svc#$svcnum";
 322
 323   my $pkgnum = $svc->cust_svc->pkgnum;
 324   my $custid = "cust_pkg#$pkgnum";
 325
 326   my @subscribers = grep { $_->{external_id} eq $svcid }
 327     $self->api_query('subscribers',
 328       [ 'customer_external_id' => $custid ]
 329     );
 330   warn "$me multiple subscribers for external_id $svcid.\n"
 331     if scalar(@subscribers) > 1;
 332
 333   $subscribers[0];
 334 }
 335
 336 # internal method: find DIDs that forward to this service
 337
 338 sub did_numbers_for_svc {
 339   my $self = shift;
 340   my $svc = shift;
 341   my @numbers;
 342   my @dids = qsearch({
 343       'table'     => 'svc_phone',
 344       'hashref'   => { 'forward_svcnum' => $svc->svcnum }
 345   });
 346   foreach my $did (@dids) {
 347     # only include them if they're interesting to this export
 348     if ( $self->svc_role($did) eq 'did' ) {
 349       my $phonenum;
 350       if ($did->countrycode) {
 351         $phonenum = Number::Phone->new('+' . $did->countrycode . $did->phonenum);
 352       } else {
 353         # the long way
 354         my $country = $did->cust_svc->cust_pkg->cust_location->country;
 355         $phonenum = Number::Phone->new($country, $did->phonenum);
 356       }
 357       if (!$phonenum) {
 358         die "Can't process phonenum ".$did->countrycode . $did->phonenum . "\n";
 359       }
 360       push @numbers,
 361         { 'cc' => $phonenum->country_code,
 362           'ac' => $phonenum->areacode,
 363           'sn' => $phonenum->subscriber
 364         };
 365     }
 366   }
 367   @numbers;
 368 }
 369
 370 sub get_subscriber_profile_set_id {
 371   my $self = shift;
 372   if ( my $setname = $self->option('subscriber_profile_set') ) {
 373     my ($set) = $self->api_query('subscriberprofilesets',
 374       [ name => $setname ]
 375     );
 376     die "Subscriber profile set '$setname' not found" unless $set;
 377     return $set->{id};
 378   }
 379   '';
 380 }
 381
 382 sub insert_subscriber {
 383   my $self = shift;
 384   my $svc = shift;
 385
 386   my $cust = $self->find_or_create_customer($svc);
 387   my $svcid = "svc#" . $svc->svcnum;
 388   my $status = $svc->cust_svc->cust_pkg->susp ? 'locked' : 'active';
 389   $status = 'active' if $svc->get('unsuspended');
 390   my $domain = $self->find_or_create_domain($svc->domain);
 391
 392   my @numbers = $self->did_numbers_for_svc($svc);
 393   my $first_number = shift @numbers;
 394
 395   my $profile_set_id = $self->get_subscriber_profile_set_id;
 396   my $subscriber = $self->api_create('subscribers',
 397     {
 398       'alias_numbers'   => \@numbers,
 399       'customer_id'     => $cust->{id},
 400       'display_name'    => $svc->finger,
 401       'domain_id'       => $domain->{id},
 402       'external_id'     => $svcid,
 403       'password'        => $svc->_password,
 404       'primary_number'  => $first_number,
 405       'profile_set_id'  => $profile_set_id,
 406       'status'          => $status,
 407       'username'        => $svc->username,
 408     }
 409   );
 410 }
 411
 412 sub replace_subscriber {
 413   my $self = shift;
 414   my $svc = shift;
 415   my $old = shift || $svc->replace_old;
 416   my $svcid = "svc#" . $svc->svcnum;
 417
 418   my $cust = $self->find_or_create_customer($svc);
 419   my $status = $svc->cust_svc->cust_pkg->susp ? 'locked' : 'active';
 420   $status = 'active' if $svc->get('unsuspended');
 421   my $domain = $self->find_or_create_domain($svc->domain);
 422
 423   my @numbers = $self->did_numbers_for_svc($svc);
 424   my $first_number = shift @numbers;
 425
 426   my $subscriber = $self->get_subscriber($svc);
 427
 428   if ( $subscriber ) {
 429     my $id = $subscriber->{id};
 430     if ( $svc->username ne $old->username ) {
 431       # have to delete and recreate
 432       $self->api_delete("subscribers/$id");
 433       $self->insert_subscriber($svc);
 434     } else {
 435       my $profile_set_id = $self->get_subscriber_profile_set_id;
 436       $self->api_update("subscribers/$id",
 437         {
 438           'alias_numbers'   => \@numbers,
 439           'customer_id'     => $cust->{id},
 440           'display_name'    => $svc->finger,
 441           'domain_id'       => $domain->{id},
 442           'email'           => $svc->email,
 443           'external_id'     => $svcid,
 444           'password'        => $svc->_password,
 445           'primary_number'  => $first_number,
 446           'profile_set_id'  => $profile_set_id,
 447           'status'          => $status,
 448           'username'        => $svc->username,
 449         }
 450       );
 451     }
 452   } else {
 453     warn "$me subscriber not found for $svcid; creating new\n";
 454     $self->insert_subscriber($svc);
 455   }
 456 }
 457
 458 sub delete_subscriber {
 459   my $self = shift;
 460   my $svc = shift;
 461   my $svcid = "svc#" . $svc->svcnum;
 462   my $pkgnum = $svc->cust_svc->pkgnum;
 463   my $custid = "cust_pkg#$pkgnum";
 464
 465   my $subscriber = $self->get_subscriber($svc);
 466
 467   if ( $subscriber ) {
 468     my $id = $subscriber->{id};
 469     $self->api_delete("subscribers/$id");
 470   } else {
 471     warn "$me subscriber not found for $svcid (would be deleted)\n";
 472   }
 473
 474   my (@other_subs) = $self->api_query('subscribers',
 475     [ 'customer_external_id' => $custid ]
 476   );
 477   if (! @other_subs) {
 478     # then it's safe to remove the customer
 479     my ($cust) = $self->api_query('customers', [ 'external_id' => $custid ]);
 480     if (!$cust) {
 481       warn "$me customer not found for $custid\n";
 482       return;
 483     }
 484     my $id = $cust->{id};
 485     my $contact_id = $cust->{contact_id};
 486     if ( $cust->{'status'} ne 'terminated' ) {
 487       # can't delete customers, have to cancel them
 488       $cust->{'status'} = 'terminated';
 489       $cust->{'external_id'} = ""; # dissociate it from this pkgnum
 490       $cust->{'contact_id'} = 1; # set to the system default contact
 491       $self->api_update("customers/$id", $cust);
 492     }
 493     # can and should delete contacts though
 494     $self->api_delete("customercontacts/$contact_id");
 495   }
 496 }
 497
 498 ################
 499 # CALL DETAILS #
 500 ################
 501
 502 =item import_cdrs START, END
 503
 504 Retrieves CDRs for calls in the date range from START to END and inserts them
 505 as a CDR batch. On success, returns a new cdr_batch object. On failure,
 506 returns an error message. If there are no new CDRs, returns nothing.
 507
 508 =cut
 509
 510 sub import_cdrs {
 511   my ($self, $start, $end) = @_;
 512   $start ||= 0;
 513   $end ||= time;
 514
 515   my $oldAutoCommit = $FS::UID::AutoCommit;
 516   local $FS::UID::AutoCommit = 0;
 517
 518   ($start, $end) = ($end, $start) if $end < $start;
 519   $start = DateTime->from_epoch(epoch => $start, time_zone => 'local');
 520   $end = DateTime->from_epoch(epoch => $end, time_zone => 'local');
 521   $end->subtract(seconds => 1); # filter by >= and <= only, so...
 522
 523   # a little different from the usual: we have to fetch these subscriber by
 524   # subscriber, not all at once.
 525   my @svcs = qsearch({
 526       'table'     => 'svc_acct',
 527       'addl_from' => ' JOIN cust_svc USING (svcnum)' .
 528                      ' JOIN export_svc USING (svcpart)',
 529       'extra_sql' => ' WHERE export_svc.role = \'subscriber\''.
 530                      ' AND export_svc.exportnum = '.$self->exportnum
 531   });
 532   my $cdr_batch;
 533   my @args = ( 'start_ge' => $start->iso8601,
 534                'start_le' => $end->iso8601,
 535               );
 536
 537   my $error;
 538   SVC: foreach my $svc (@svcs) {
 539     my $subscriber = $self->get_subscriber($svc);
 540     if (!$subscriber) {
 541       warn "$me user ".$svc->label." is not configured on the SIP server.\n";
 542       next;
 543     }
 544     my $id = $subscriber->{id};
 545     my @calls;
 546     try {
 547       # alias_field tells "calllists" which field from the source and
 548       # destination to use as the "own_cli" and "other_cli" of the call.
 549       # "user" = username@domain.
 550       @calls = $self->api_query('calllists', [
 551           'subscriber_id' => $id,
 552           'alias_field'   => 'user',
 553           @args
 554       ]);
 555     } catch {
 556       $error = "$me $_ (retrieving records for ".$svc->label.")";
 557     };
 558
 559     if (@calls and !$cdr_batch) {
 560       # create a cdr_batch if needed
 561       my $cdrbatchname = 'sipwise-' . $self->exportnum . '-' . $end->epoch;
 562       $cdr_batch = FS::cdr_batch->new({ cdrbatch => $cdrbatchname });
 563       $error = $cdr_batch->insert;
 564     }
 565
 566     last SVC if $error;
 567
 568     foreach my $c (@calls) {
 569       # avoid double-importing
 570       my $uniqueid = $c->{call_id};
 571       if ( FS::cdr->row_exists("uniqueid = ?", $uniqueid) ) {
 572         warn "skipped call with uniqueid = '$uniqueid' (already imported)\n"
 573           if $DEBUG;
 574         next;
 575       }
 576       my $src = $c->{own_cli};
 577       my $dst = $c->{other_cli};
 578       if ( $c->{direction} eq 'in' ) { # then reverse them
 579         ($src, $dst) = ($dst, $src);
 580       }
 581       # parse duration from H:MM:SS format
 582       my $duration;
 583       if ( $c->{duration} =~ /^(\d+):(\d+):(\d+)$/ ) {
 584         $duration = $3 + (60 * $2) + (3600 * $1);
 585       } else {
 586         $error = "call $uniqueid: unparseable duration '".$c->{duration}."'";
 587       }
 588
 589       # use the username@domain label for src and/or dst if possible
 590       my $cdr = FS::cdr->new({
 591           uniqueid        => $uniqueid,
 592           upstream_price  => $c->{customer_cost},
 593           startdate       => parse_datetime($c->{start_time}),
 594           disposition     => $c->{status},
 595           duration        => $duration,
 596           billsec         => $duration,
 597           src             => $src,
 598           dst             => $dst,
 599       });
 600       $error ||= $cdr->insert;
 601       last SVC if $error;
 602     }
 603   } # foreach $svc
 604
 605   if ( $error ) {
 606     dbh->rollback if $oldAutoCommit;
 607     return $error;
 608   } elsif ( $cdr_batch ) {
 609     dbh->commit if $oldAutoCommit;
 610     return $cdr_batch;
 611   } else { # no CDRs
 612     return;
 613   }
 614 }
 615
 616 ##############
 617 # API ACCESS #
 618 ##############
 619
 620 =item api_query RESOURCE, CONTENT
 621
 622 Makes a GET request to RESOURCE, the name of a resource type (like
 623 'customers'), with query parameters in CONTENT, unpacks the embedded search
 624 results, and returns them as a list.
 625
 626 Sipwise ignores invalid query parameters rather than throwing an error, so if
 627 the parameters are misspelled or make no sense for this type of query, it will
 628 probably return all of the objects.
 629
 630 =cut
 631
 632 sub api_query {
 633   my $self = shift;
 634   my ($resource, $content) = @_;
 635   if ( ref $content eq 'HASH' ) {
 636     $content = [ %$content ];
 637   }
 638   my $page = 1;
 639   push @$content, ('rows' => 100, 'page' => 1); # 'page' is always last
 640   my $result = $self->api_request('GET', $resource, $content);
 641   my @records;
 642   # depaginate
 643   while ( my $things = $result->{_embedded}{"ngcp:$resource"} ) {
 644     if ( ref($things) eq 'ARRAY' ) {
 645       push @records, @$things;
 646     } else {
 647       push @records, $things;
 648     }
 649     if ( my $linknext = $result->{_links}{next} ) {
 650       # unfortunately their HAL isn't entirely functional
 651       # it returns "next" links that contain "page" and "rows" but no other
 652       # parameters. so just count the pages:
 653       $page++;
 654       $content->[-1] = $page;
 655
 656       warn "$me continued: $page\n" if $DEBUG;
 657       $result = $self->api_request('GET', $resource, $content);
 658     } else {
 659       last;
 660     }
 661   }
 662   return @records;
 663 }
 664
 665 =item api_create RESOURCE, CONTENT
 666
 667 Makes a POST request to RESOURCE, the name of a resource type (like
 668 'customers'), to create a new object of that type. CONTENT must be a hashref of
 669 the object's fields.
 670
 671 On success, will then fetch and return the newly created object. On failure,
 672 will throw the "message" parameter from the request as an exception.
 673
 674 =cut
 675
 676 sub api_create {
 677   my $self = shift;
 678   my ($resource, $content) = @_;
 679   my $result = $self->api_request('POST', $resource, $content);
 680   if ( $result->{location} ) {
 681     return $self->api_request('GET', $result->{location});
 682   } else {
 683     die $result->{message} . "\n";
 684   }
 685 }
 686
 687 =item api_update ENDPOINT, CONTENT
 688
 689 Makes a PUT request to ENDPOINT, the name of a specific record (like
 690 'customers/11'), to replace it with the data in CONTENT (a hashref of the
 691 object's fields). On failure, will throw an exception. On success,
 692 returns nothing.
 693
 694 =cut
 695
 696 sub api_update {
 697   my $self = shift;
 698   my ($endpoint, $content) = @_;
 699   my $result = $self->api_request('PUT', $endpoint, $content);
 700   if ( $result->{message} ) {
 701     die $result->{message} . "\n";
 702   }
 703   return;
 704 }
 705
 706 =item api_delete ENDPOINT
 707
 708 Makes a DELETE request to ENDPOINT. On failure, will throw an exception.
 709
 710 =cut
 711
 712 sub api_delete {
 713   my $self = shift;
 714   my $endpoint = shift;
 715   my $result = $self->api_request('DELETE', $endpoint);
 716   if ( $result->{code} and $result->{code} eq '404' ) {
 717     # special case: this is harmless. we tried to delete something and it
 718     # was already gone.
 719     warn "$me api_delete $endpoint: does not exist\n";
 720     return;
 721   } elsif ( $result->{message} ) {
 722     die $result->{message} . "\n";
 723   }
 724   return;
 725 }
 726
 727 =item api_request METHOD, ENDPOINT, CONTENT
 728
 729 Makes a REST request with HTTP method METHOD, to path ENDPOINT, with content
 730 CONTENT. If METHOD is GET, the content can be an arrayref or hashref to append
 731 as the query argument. If it's POST or PUT, the content will be JSON-serialized
 732 and sent as the request body. If it's DELETE, content will be ignored.
 733
 734 =cut
 735
 736 sub api_request {
 737   my $self = shift;
 738   my ($method, $endpoint, $content) = @_;
 739   $DEBUG ||= 1 if $self->option('debug');
 740   my $url;
 741   if ($endpoint =~ /^http/) {
 742     # allow directly using URLs returned from the API
 743     $url = $endpoint;
 744   } else {
 745     $endpoint =~ s[/api/][]; # allow using paths returned in Location headers
 746     $url = 'https://' . $self->host . '/api/' . $endpoint;
 747     $url .= '/' unless $url =~ m[/$];
 748   }
 749   my $request;
 750   if ( lc($method) eq 'get' ) {
 751     $url = URI->new($url);
 752     $url->query_form($content);
 753     $request = GET($url,
 754       'Accept'        => 'application/json'
 755     );
 756   } elsif ( lc($method) eq 'post' ) {
 757     $request = POST($url,
 758       'Accept'        => 'application/json',
 759       'Content'       => encode_json($content),
 760       'Content-Type'  => 'application/json',
 761     );
 762   } elsif ( lc($method) eq 'put' ) {
 763     $request = PUT($url,
 764       'Accept'        => 'application/json',
 765       'Content'       => encode_json($content),
 766       'Content-Type'  => 'application/json',
 767     );
 768   } elsif ( lc($method) eq 'delete' ) {
 769     $request = DELETE($url);
 770   }
 771
 772   warn "$me $method $endpoint\n" if $DEBUG;
 773   warn $request->as_string ."\n" if $DEBUG > 1;
 774   my $response = $self->ua->request($request);
 775   warn "$me received\n" . $response->as_string ."\n" if $DEBUG > 1;
 776
 777   my $decoded_response = {};
 778   if ( $response->content ) {
 779     local $@;
 780     $decoded_response = eval { decode_json($response->content) };
 781     if ( $@ ) {
 782       # then it can't be parsed; probably a low-level error of some kind.
 783       warn "$me Parse error.\n".$response->content."\n\n";
 784       die "$me Parse error:".$response->content . "\n";
 785     }
 786   }
 787   if ( $response->header('Location') ) {
 788     $decoded_response->{location} = $response->header('Location');
 789   }
 790   return $decoded_response;
 791 }
 792
 793 # a little false laziness with aradial.pm
 794 sub host {
 795   my $self = shift;
 796   my $port = $self->option('port') || 1443;
 797   $self->machine . ":$port";
 798 }
 799
 800 sub ua {
 801   my $self = shift;
 802   $self->{_ua} ||= do {
 803     my @opt;
 804     if ( $self->option('ssl_no_verify') ) {
 805       push @opt, ssl_opts => {
 806                    verify_hostname => 0,
 807                    SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE,
 808                  };
 809     }
 810     my $ua = LWP::UserAgent->new(@opt);
 811     $ua->credentials(
 812       $self->host,
 813       'api_admin_http',
 814       $self->option('username'),
 815       $self->option('password')
 816     );
 817     $ua;
 818   }
 819 }
 820
 821
 822 1;