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