added on local at 2026-07-01 15:02:49
| 1 | package MODS::ContactForge::Adapter::Base; | |
| 2 | #====================================================================== | |
| 3 | # ContactForge - abstract base every integration adapter inherits from. | |
| 4 | # | |
| 5 | # Provides the HTTP plumbing (curl IPC, because LWP::Protocol::https | |
| 6 | # is not installed on the box) and a single 401-with-refresh retry. | |
| 7 | # Subclasses must implement provider_slug, backfill, poll, disconnect. | |
| 8 | #====================================================================== | |
| 9 | use strict; | |
| 10 | use warnings; | |
| 11 | use JSON::PP; | |
| 12 | ||
| 13 | #---------------------------------------------------------------------- | |
| 14 | # new({ connection => ..., sync => $sync, db => $db, dbh => $dbh, | |
| 15 | # DB => $DB }) | |
| 16 | #---------------------------------------------------------------------- | |
| 17 | sub new { | |
| 18 | my ($class, $args) = @_; | |
| 19 | $args ||= {}; | |
| 20 | my $self = { | |
| 21 | connection => $args->{connection} || {}, | |
| 22 | sync => $args->{sync}, | |
| 23 | db => $args->{db}, | |
| 24 | dbh => $args->{dbh}, | |
| 25 | DB => $args->{DB}, | |
| 26 | _refreshed_once => 0, | |
| 27 | }; | |
| 28 | return bless $self, $class; | |
| 29 | } | |
| 30 | ||
| 31 | # Subclasses override. | |
| 32 | sub provider_slug { return ''; } | |
| 33 | sub backfill { return { pulled => 0 }; } | |
| 34 | sub poll { return { pulled => 0 }; } | |
| 35 | sub disconnect { return 1; } | |
| 36 | ||
| 37 | # Re-read the connection row after a refresh has rewritten access_token, | |
| 38 | # so subsequent calls in this run pick up the new bearer. | |
| 39 | sub _reload_connection { | |
| 40 | my ($self) = @_; | |
| 41 | my $cid = $self->{connection}->{id} or return; | |
| 42 | my $fresh = $self->{sync}->connection($self->{db}, $self->{dbh}, | |
| 43 | $self->{DB}, $cid); | |
| 44 | $self->{connection} = $fresh if $fresh; | |
| 45 | } | |
| 46 | ||
| 47 | #---------------------------------------------------------------------- | |
| 48 | # http_get / http_post -- thin wrappers around the curl IPC pattern. | |
| 49 | # Returns { status, body } where status is best-effort (200 unless we | |
| 50 | # manage to capture a real code via -w). | |
| 51 | #---------------------------------------------------------------------- | |
| 52 | sub http_get { | |
| 53 | my ($self, $url, %headers) = @_; | |
| 54 | return $self->_curl_request('GET', $url, undef, \%headers); | |
| 55 | } | |
| 56 | ||
| 57 | sub http_post { | |
| 58 | my ($self, $url, $body, %headers) = @_; | |
| 59 | return $self->_curl_request('POST', $url, $body, \%headers); | |
| 60 | } | |
| 61 | ||
| 62 | #---------------------------------------------------------------------- | |
| 63 | # http_json -- convenience for JSON APIs. Encodes ref bodies, decodes | |
| 64 | # the response. Auto-refresh on first 401 then retries once. | |
| 65 | # Returns { status, body, json } -- caller checks json + status. | |
| 66 | #---------------------------------------------------------------------- | |
| 67 | sub http_json { | |
| 68 | my ($self, $url, $method, $body) = @_; | |
| 69 | $method ||= 'GET'; | |
| 70 | ||
| 71 | my $payload = ''; | |
| 72 | if (ref $body) { | |
| 73 | eval { $payload = encode_json($body); 1 } or $payload = ''; | |
| 74 | } elsif (defined $body) { | |
| 75 | $payload = $body; | |
| 76 | } | |
| 77 | ||
| 78 | my $access = $self->{connection}->{access_token} || ''; | |
| 79 | my %headers = ( | |
| 80 | 'Authorization' => "Bearer $access", | |
| 81 | 'Accept' => 'application/json', | |
| 82 | ); | |
| 83 | $headers{'Content-Type'} = 'application/json' if $method ne 'GET'; | |
| 84 | ||
| 85 | my $res = $self->_curl_request($method, $url, $payload, \%headers); | |
| 86 | $res->{json} = _safe_decode($res->{body}); | |
| 87 | ||
| 88 | if (_looks_like_401($res) && !$self->{_refreshed_once}) { | |
| 89 | $self->{_refreshed_once} = 1; | |
| 90 | my $r = $self->{sync}->refresh_token($self->{db}, $self->{dbh}, | |
| 91 | $self->{DB}, | |
| 92 | $self->{connection}->{id}); | |
| 93 | if ($r && $r->{ok}) { | |
| 94 | $self->_reload_connection; | |
| 95 | $access = $self->{connection}->{access_token} || ''; | |
| 96 | $headers{'Authorization'} = "Bearer $access"; | |
| 97 | $res = $self->_curl_request($method, $url, $payload, \%headers); | |
| 98 | $res->{json} = _safe_decode($res->{body}); | |
| 99 | } | |
| 100 | } | |
| 101 | return $res; | |
| 102 | } | |
| 103 | ||
| 104 | #====================================================================== | |
| 105 | # Private | |
| 106 | #====================================================================== | |
| 107 | ||
| 108 | sub _curl_request { | |
| 109 | my ($self, $method, $url, $body, $headers) = @_; | |
| 110 | my @cmd = ('curl', '-s', '-w', "\n___STATUS:%{http_code}", '-X', $method); | |
| 111 | foreach my $h (sort keys %$headers) { | |
| 112 | my $v = $headers->{$h}; | |
| 113 | next unless defined $v; | |
| 114 | push @cmd, '-H', "$h: $v"; | |
| 115 | } | |
| 116 | if (defined $body && length $body) { | |
| 117 | push @cmd, '--data-binary', $body; | |
| 118 | } | |
| 119 | push @cmd, $url; | |
| 120 | ||
| 121 | my $out = ''; | |
| 122 | if (open(my $fh, '-|', @cmd)) { | |
| 123 | local $/; | |
| 124 | $out = <$fh>; | |
| 125 | close $fh; | |
| 126 | } | |
| 127 | my $status = 200; | |
| 128 | if ($out =~ s/\n___STATUS:(\d+)\s*$//) { | |
| 129 | $status = $1 + 0; | |
| 130 | } | |
| 131 | return { status => $status, body => $out }; | |
| 132 | } | |
| 133 | ||
| 134 | sub _looks_like_401 { | |
| 135 | my ($res) = @_; | |
| 136 | return 0 unless $res; | |
| 137 | return 1 if ($res->{status} || 0) == 401; | |
| 138 | # Some providers respond 200 with an INVALID_SESSION_ID body -- | |
| 139 | # opt out of the heuristic so we don't refresh forever. | |
| 140 | return 0; | |
| 141 | } | |
| 142 | ||
| 143 | sub _safe_decode { | |
| 144 | my ($s) = @_; | |
| 145 | return undef unless defined $s && length $s; | |
| 146 | my $j; | |
| 147 | eval { $j = decode_json($s); 1 } or return undef; | |
| 148 | return $j; | |
| 149 | } | |
| 150 | ||
| 151 | 1; |