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 use Carp qw(carp);
  18
  19 our $me = '[sipwise]';
  20 our $DEBUG = 0;
  21
  22 tie my %options, 'Tie::IxHash',
  23   'port'            => { label => 'Port' },
  24   'username'        => { label => 'API username', },
  25   'password'        => { label => 'API password', },
  26   'debug'           => { label => 'Enable debugging', type => 'checkbox', value => 1 },
  27   'billing_profile' => {
  28     label             => 'Billing profile handle',
  29     default           => 'default',
  30   },
  31   'subscriber_profile_set' => {
  32     label             => 'Subscriber profile set name (optional)',
  33   },
  34   'reseller_id'     => { label => 'Reseller ID' },
  35   'ssl_no_verify'   => { label => 'Skip SSL certificate validation',
  36                          type  => 'checkbox',
  37                        },
  38 ;
  39
  40 tie my %roles, 'Tie::IxHash',
  41   'subscriber'    => {  label     => 'Subscriber',
  42                         svcdb     => 'svc_acct',
  43                         multiple  => 1,
  44                      },
  45   'did'           => {  label     => 'DID',
  46                         svcdb     => 'svc_phone',
  47                         multiple  => 1,
  48                      },
  49 ;
  50
  51 our %info = (
  52   'svc'      => [qw( svc_acct svc_phone )],
  53   'desc'     => 'Provision to a Sipwise sip:provider server',
  54   'options'  => \%options,
  55   'roles'    => \%roles,
  56   'notes'    => <<'END'
  57 <P>Export to a <b>sip:provider</b> server.</P>
  58 <P>This requires two service definitions to be configured on the same package:
  59   <OL>
  60     <LI>An account service for a SIP client account ("subscriber"). The
  61     <i>username</i> will be the SIP username. The <i>domsvc</i> should point
  62     to a domain service to use as the SIP domain name.</LI>
  63     <LI>A phone service for a DID. The <i>phonenum</i> here will be a PSTN
  64     number. The <i>forward_svcnum</i> field should be set to the account that
  65     will receive calls at this number.
  66   </OL>
  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
 300   if ( $FS::svc_Common::noexport_hack ) {
 301     carp 'export_did() suppressed by noexport_hack'
 302       if $self->option('debug') || $DEBUG;
 303     return;
 304   }
 305
 306   if ( $old and $new->forward_svcnum ne $old->forward_svcnum ) {
 307     my $old_svc_acct = $self->acct_for_did($old);
 308     $self->replace_subscriber( $old_svc_acct ) if $old_svc_acct;
 309   }
 310   my $new_svc_acct = $self->acct_for_did($new);
 311   $self->replace_subscriber( $new_svc_acct ) if $new_svc_acct;
 312 }
 313
 314 ###############
 315 # SUBSCRIBERS #
 316 ###############
 317
 318 =item get_subscriber SVC
 319
 320 Gets the subscriber record for SVC, if there is one.
 321
 322 =cut
 323
 324 sub get_subscriber {
 325   my $self = shift;
 326   my $svc = shift;
 327
 328   my $svcnum = $svc->svcnum;
 329   my $svcid = "svc#$svcnum";
 330
 331   my $pkgnum = $svc->cust_svc->pkgnum;
 332   my $custid = "cust_pkg#$pkgnum";
 333
 334   my @subscribers = grep { $_->{external_id} eq $svcid }
 335     $self->api_query('subscribers',
 336       [ 'customer_external_id' => $custid ]
 337     );
 338   warn "$me multiple subscribers for external_id $svcid.\n"
 339     if scalar(@subscribers) > 1;
 340
 341   $subscribers[0];
 342 }
 343
 344 # internal method: find DIDs that forward to this service
 345
 346 sub did_numbers_for_svc {
 347   my $self = shift;
 348   my $svc = shift;
 349   my @numbers;
 350   my @dids = qsearch({
 351       'table'     => 'svc_phone',
 352       'hashref'   => { 'forward_svcnum' => $svc->svcnum }
 353   });
 354   foreach my $did (@dids) {
 355     # only include them if they're interesting to this export
 356     if ( $self->svc_role($did) eq 'did' ) {
 357       my $phonenum;
 358       if ($did->countrycode) {
 359         $phonenum = Number::Phone->new('+' . $did->countrycode . $did->phonenum);
 360       } else {
 361         # the long way
 362         my $country = $did->cust_svc->cust_pkg->cust_location->country;
 363         $phonenum = Number::Phone->new($country, $did->phonenum);
 364       }
 365       if (!$phonenum) {
 366         die "Can't process phonenum ".$did->countrycode . $did->phonenum . "\n";
 367       }
 368       push @numbers,
 369         { 'cc' => $phonenum->country_code,
 370           'ac' => $phonenum->areacode,
 371           'sn' => $phonenum->subscriber
 372         };
 373     }
 374   }
 375   @numbers;
 376 }
 377
 378 sub get_subscriber_profile_set_id {
 379   my $self = shift;
 380   if ( my $setname = $self->option('subscriber_profile_set') ) {
 381     my ($set) = $self->api_query('subscriberprofilesets',
 382       [ name => $setname ]
 383     );
 384     die "Subscriber profile set '$setname' not found" unless $set;
 385     return $set->{id};
 386   }
 387   '';
 388 }
 389
 390 sub insert_subscriber {
 391   my $self = shift;
 392   my $svc = shift;
 393
 394   my $cust = $self->find_or_create_customer($svc);
 395   my $svcid = "svc#" . $svc->svcnum;
 396   my $status = $svc->cust_svc->cust_pkg->susp ? 'locked' : 'active';
 397   $status = 'active' if $svc->get('unsuspended');
 398   my $domain = $self->find_or_create_domain($svc->domain);
 399
 400   my @numbers = $self->did_numbers_for_svc($svc);
 401   my $first_number = shift @numbers;
 402
 403   my $profile_set_id = $self->get_subscriber_profile_set_id;
 404   my $subscriber = $self->api_create('subscribers',
 405     {
 406       'alias_numbers'   => \@numbers,
 407       'customer_id'     => $cust->{id},
 408       'display_name'    => $svc->finger,
 409       'domain_id'       => $domain->{id},
 410       'external_id'     => $svcid,
 411       'password'        => $svc->_password,
 412       'primary_number'  => $first_number,
 413       'profile_set_id'  => $profile_set_id,
 414       'status'          => $status,
 415       'username'        => $svc->username,
 416     }
 417   );
 418 }
 419
 420 sub replace_subscriber {
 421   my $self = shift;
 422   my $svc = shift;
 423   my $old = shift || $svc->replace_old;
 424   my $svcid = "svc#" . $svc->svcnum;
 425
 426   my $cust = $self->find_or_create_customer($svc);
 427   my $status = $svc->cust_svc->cust_pkg->susp ? 'locked' : 'active';
 428   $status = 'active' if $svc->get('unsuspended');
 429   my $domain = $self->find_or_create_domain($svc->domain);
 430
 431   my @numbers = $self->did_numbers_for_svc($svc);
 432   my $first_number = shift @numbers;
 433
 434   my $subscriber = $self->get_subscriber($svc);
 435
 436   if ( $subscriber ) {
 437     my $id = $subscriber->{id};
 438     if ( $svc->username ne $old->username ) {
 439       # have to delete and recreate
 440       $self->api_delete("subscribers/$id");
 441       $self->insert_subscriber($svc);
 442     } else {
 443       my $profile_set_id = $self->get_subscriber_profile_set_id;
 444       $self->api_update("subscribers/$id",
 445         {
 446           'alias_numbers'   => \@numbers,
 447           'customer_id'     => $cust->{id},
 448           'display_name'    => $svc->finger,
 449           'domain_id'       => $domain->{id},
 450           'email'           => $svc->email,
 451           'external_id'     => $svcid,
 452           'password'        => $svc->_password,
 453           'primary_number'  => $first_number,
 454           'profile_set_id'  => $profile_set_id,
 455           'status'          => $status,
 456           'username'        => $svc->username,
 457         }
 458       );
 459     }
 460   } else {
 461     warn "$me subscriber not found for $svcid; creating new\n";
 462     $self->insert_subscriber($svc);
 463   }
 464 }
 465
 466 sub delete_subscriber {
 467   my $self = shift;
 468   my $svc = shift;
 469   my $svcid = "svc#" . $svc->svcnum;
 470   my $pkgnum = $svc->cust_svc->pkgnum;
 471   my $custid = "cust_pkg#$pkgnum";
 472
 473   my $subscriber = $self->get_subscriber($svc);
 474
 475   if ( $subscriber ) {
 476     my $id = $subscriber->{id};
 477     $self->api_delete("subscribers/$id");
 478   } else {
 479     warn "$me subscriber not found for $svcid (would be deleted)\n";
 480   }
 481
 482   my (@other_subs) = $self->api_query('subscribers',
 483     [ 'customer_external_id' => $custid ]
 484   );
 485   if (! @other_subs) {
 486     # then it's safe to remove the customer
 487     my ($cust) = $self->api_query('customers', [ 'external_id' => $custid ]);
 488     if (!$cust) {
 489       warn "$me customer not found for $custid\n";
 490       return;
 491     }
 492     my $id = $cust->{id};
 493     my $contact_id = $cust->{contact_id};
 494     if ( $cust->{'status'} ne 'terminated' ) {
 495       # can't delete customers, have to cancel them
 496       $cust->{'status'} = 'terminated';
 497       $cust->{'external_id'} = ""; # dissociate it from this pkgnum
 498       $cust->{'contact_id'} = 1; # set to the system default contact
 499       $self->api_update("customers/$id", $cust);
 500     }
 501     # can and should delete contacts though
 502     $self->api_delete("customercontacts/$contact_id");
 503   }
 504 }
 505
 506 ################
 507 # CALL DETAILS #
 508 ################
 509
 510 =item import_cdrs START, END
 511
 512 Retrieves CDRs for calls in the date range from START to END and inserts them
 513 as a CDR batch. On success, returns a new cdr_batch object. On failure,
 514 returns an error message. If there are no new CDRs, returns nothing.
 515
 516 =cut
 517
 518 sub import_cdrs {
 519   my ($self, $start, $end) = @_;
 520   $start ||= 0;
 521   $end ||= time;
 522
 523   my $oldAutoCommit = $FS::UID::AutoCommit;
 524   local $FS::UID::AutoCommit = 0;
 525
 526   ($start, $end) = ($end, $start) if $end < $start;
 527   $start = DateTime->from_epoch(epoch => $start, time_zone => 'local');
 528   $end = DateTime->from_epoch(epoch => $end, time_zone => 'local');
 529   $end->subtract(seconds => 1); # filter by >= and <= only, so...
 530
 531   # a little different from the usual: we have to fetch these subscriber by
 532   # subscriber, not all at once.
 533   my @svcs = qsearch({
 534       'table'     => 'svc_acct',
 535       'addl_from' => ' JOIN cust_svc USING (svcnum)' .
 536                      ' JOIN export_svc USING (svcpart)',
 537       'extra_sql' => ' WHERE export_svc.role = \'subscriber\''.
 538                      ' AND export_svc.exportnum = '.$self->exportnum
 539   });
 540   my $cdr_batch;
 541   my @args = ( 'start_ge' => $start->iso8601,
 542                'start_le' => $end->iso8601,
 543               );
 544
 545   my $error;
 546   SVC: foreach my $svc (@svcs) {
 547     my $subscriber = $self->get_subscriber($svc);
 548     if (!$subscriber) {
 549       warn "$me user ".$svc->label." is not configured on the SIP server.\n";
 550       next;
 551     }
 552     my $id = $subscriber->{id};
 553     my @calls;
 554     try {
 555       # alias_field tells "calllists" which field from the source and
 556       # destination to use as the "own_cli" and "other_cli" of the call.
 557       # "user" = username@domain.
 558       @calls = $self->api_query('calllists', [
 559           'subscriber_id' => $id,
 560           'alias_field'   => 'user',
 561           @args
 562       ]);
 563     } catch {
 564       $error = "$me $_ (retrieving records for ".$svc->label.")";
 565     };
 566
 567     if (@calls and !$cdr_batch) {
 568       # create a cdr_batch if needed
 569       my $cdrbatchname = 'sipwise-' . $self->exportnum . '-' . $end->epoch;
 570       $cdr_batch = FS::cdr_batch->new({ cdrbatch => $cdrbatchname });
 571       $error = $cdr_batch->insert;
 572     }
 573
 574     last SVC if $error;
 575
 576     foreach my $c (@calls) {
 577       # avoid double-importing
 578       my $uniqueid = $c->{call_id};
 579       if ( FS::cdr->row_exists("uniqueid = ?", $uniqueid) ) {
 580         warn "skipped call with uniqueid = '$uniqueid' (already imported)\n"
 581           if $DEBUG;
 582         next;
 583       }
 584       my $src = $c->{own_cli};
 585       my $dst = $c->{other_cli};
 586       if ( $c->{direction} eq 'in' ) { # then reverse them
 587         ($src, $dst) = ($dst, $src);
 588       }
 589       # parse duration from H:MM:SS format
 590       my $duration;
 591       if ( $c->{duration} =~ /^(\d+):(\d+):(\d+)$/ ) {
 592         $duration = $3 + (60 * $2) + (3600 * $1);
 593       } else {
 594         $error = "call $uniqueid: unparseable duration '".$c->{duration}."'";
 595       }
 596
 597       # use the username@domain label for src and/or dst if possible
 598       my $cdr = FS::cdr->new({
 599           uniqueid        => $uniqueid,
 600           upstream_price  => $c->{customer_cost},
 601           startdate       => parse_datetime($c->{start_time}),
 602           disposition     => $c->{status},
 603           duration        => $duration,
 604           billsec         => $duration,
 605           src             => $src,
 606           dst             => $dst,
 607       });
 608       $error ||= $cdr->insert;
 609       last SVC if $error;
 610     }
 611   } # foreach $svc
 612
 613   if ( $error ) {
 614     dbh->rollback if $oldAutoCommit;
 615     return $error;
 616   } elsif ( $cdr_batch ) {
 617     dbh->commit if $oldAutoCommit;
 618     return $cdr_batch;
 619   } else { # no CDRs
 620     return;
 621   }
 622 }
 623
 624 ##############
 625 # API ACCESS #
 626 ##############
 627
 628 =item api_query RESOURCE, CONTENT
 629
 630 Makes a GET request to RESOURCE, the name of a resource type (like
 631 'customers'), with query parameters in CONTENT, unpacks the embedded search
 632 results, and returns them as a list.
 633
 634 Sipwise ignores invalid query parameters rather than throwing an error, so if
 635 the parameters are misspelled or make no sense for this type of query, it will
 636 probably return all of the objects.
 637
 638 =cut
 639
 640 sub api_query {
 641   my $self = shift;
 642   my ($resource, $content) = @_;
 643   if ( ref $content eq 'HASH' ) {
 644     $content = [ %$content ];
 645   }
 646   my $page = 1;
 647   push @$content, ('rows' => 100, 'page' => 1); # 'page' is always last
 648   my $result = $self->api_request('GET', $resource, $content);
 649   my @records;
 650   # depaginate
 651   while ( my $things = $result->{_embedded}{"ngcp:$resource"} ) {
 652     if ( ref($things) eq 'ARRAY' ) {
 653       push @records, @$things;
 654     } else {
 655       push @records, $things;
 656     }
 657     if ( my $linknext = $result->{_links}{next} ) {
 658       # unfortunately their HAL isn't entirely functional
 659       # it returns "next" links that contain "page" and "rows" but no other
 660       # parameters. so just count the pages:
 661       $page++;
 662       $content->[-1] = $page;
 663
 664       warn "$me continued: $page\n" if $DEBUG;
 665       $result = $self->api_request('GET', $resource, $content);
 666     } else {
 667       last;
 668     }
 669   }
 670   return @records;
 671 }
 672
 673 =item api_create RESOURCE, CONTENT
 674
 675 Makes a POST request to RESOURCE, the name of a resource type (like
 676 'customers'), to create a new object of that type. CONTENT must be a hashref of
 677 the object's fields.
 678
 679 On success, will then fetch and return the newly created object. On failure,
 680 will throw the "message" parameter from the request as an exception.
 681
 682 =cut
 683
 684 sub api_create {
 685   my $self = shift;
 686   my ($resource, $content) = @_;
 687   my $result = $self->api_request('POST', $resource, $content);
 688   if ( $result->{location} ) {
 689     return $self->api_request('GET', $result->{location});
 690   } else {
 691     die $result->{message} . "\n";
 692   }
 693 }
 694
 695 =item api_update ENDPOINT, CONTENT
 696
 697 Makes a PUT request to ENDPOINT, the name of a specific record (like
 698 'customers/11'), to replace it with the data in CONTENT (a hashref of the
 699 object's fields). On failure, will throw an exception. On success,
 700 returns nothing.
 701
 702 =cut
 703
 704 sub api_update {
 705   my $self = shift;
 706   my ($endpoint, $content) = @_;
 707   my $result = $self->api_request('PUT', $endpoint, $content);
 708   if ( $result->{message} ) {
 709     die $result->{message} . "\n";
 710   }
 711   return;
 712 }
 713
 714 =item api_delete ENDPOINT
 715
 716 Makes a DELETE request to ENDPOINT. On failure, will throw an exception.
 717
 718 =cut
 719
 720 sub api_delete {
 721   my $self = shift;
 722   my $endpoint = shift;
 723   my $result = $self->api_request('DELETE', $endpoint);
 724   if ( $result->{code} and $result->{code} eq '404' ) {
 725     # special case: this is harmless. we tried to delete something and it
 726     # was already gone.
 727     warn "$me api_delete $endpoint: does not exist\n";
 728     return;
 729   } elsif ( $result->{message} ) {
 730     die $result->{message} . "\n";
 731   }
 732   return;
 733 }
 734
 735 =item api_request METHOD, ENDPOINT, CONTENT
 736
 737 Makes a REST request with HTTP method METHOD, to path ENDPOINT, with content
 738 CONTENT. If METHOD is GET, the content can be an arrayref or hashref to append
 739 as the query argument. If it's POST or PUT, the content will be JSON-serialized
 740 and sent as the request body. If it's DELETE, content will be ignored.
 741
 742 =cut
 743
 744 sub api_request {
 745   my $self = shift;
 746   my ($method, $endpoint, $content) = @_;
 747   $DEBUG ||= 1 if $self->option('debug');
 748   my $url;
 749   if ($endpoint =~ /^http/) {
 750     # allow directly using URLs returned from the API
 751     $url = $endpoint;
 752   } else {
 753     $endpoint =~ s[/api/][]; # allow using paths returned in Location headers
 754     $url = 'https://' . $self->host . '/api/' . $endpoint;
 755     $url .= '/' unless $url =~ m[/$];
 756   }
 757   my $request;
 758   if ( lc($method) eq 'get' ) {
 759     $url = URI->new($url);
 760     $url->query_form($content);
 761     $request = GET($url,
 762       'Accept'        => 'application/json'
 763     );
 764   } elsif ( lc($method) eq 'post' ) {
 765     $request = POST($url,
 766       'Accept'        => 'application/json',
 767       'Content'       => encode_json($content),
 768       'Content-Type'  => 'application/json',
 769     );
 770   } elsif ( lc($method) eq 'put' ) {
 771     $request = PUT($url,
 772       'Accept'        => 'application/json',
 773       'Content'       => encode_json($content),
 774       'Content-Type'  => 'application/json',
 775     );
 776   } elsif ( lc($method) eq 'delete' ) {
 777     $request = DELETE($url);
 778   }
 779
 780   warn "$me $method $endpoint\n" if $DEBUG;
 781   warn $request->as_string ."\n" if $DEBUG > 1;
 782   my $response = $self->ua->request($request);
 783   warn "$me received\n" . $response->as_string ."\n" if $DEBUG > 1;
 784
 785   my $decoded_response = {};
 786   if ( $response->content ) {
 787     local $@;
 788     $decoded_response = eval { decode_json($response->content) };
 789     if ( $@ ) {
 790       # then it can't be parsed; probably a low-level error of some kind.
 791       warn "$me Parse error.\n".$response->content."\n\n";
 792       die "$me Parse error:".$response->content . "\n";
 793     }
 794   }
 795   if ( $response->header('Location') ) {
 796     $decoded_response->{location} = $response->header('Location');
 797   }
 798   return $decoded_response;
 799 }
 800
 801 # a little false laziness with aradial.pm
 802 sub host {
 803   my $self = shift;
 804   my $port = $self->option('port') || 1443;
 805   $self->machine . ":$port";
 806 }
 807
 808 sub ua {
 809   my $self = shift;
 810   $self->{_ua} ||= do {
 811     my @opt;
 812     if ( $self->option('ssl_no_verify') ) {
 813       push @opt, ssl_opts => {
 814                    verify_hostname => 0,
 815                    SSL_verify_mode => IO::Socket::SSL::SSL_VERIFY_NONE,
 816                  };
 817     }
 818     my $ua = LWP::UserAgent->new(@opt);
 819     $ua->credentials(
 820       $self->host,
 821       'api_admin_http',
 822       $self->option('username'),
 823       $self->option('password')
 824     );
 825     $ua;
 826   }
 827 }
 828
 829
 830 1;