package Net::Async::Github; use strict; use warnings; our $VERSION = '0.013'; our $AUTHORITY = 'cpan:TEAM'; # AUTHORITY use parent qw(IO::Async::Notifier); no indirect; use utf8; =encoding utf8 =head1 NAME Net::Async::Github - support for the L REST API with L =head1 SYNOPSIS use IO::Async::Loop; use Net::Async::Github; my $loop = IO::Async::Loop->new; $loop->add( my $gh = Net::Async::Github->new( token => '...', ) ); # Give 'secret_team' pull access to all private repos $gh->repos(visibility => 'private') ->grant_team(secret_team => 'pull') ->await; =head1 DESCRIPTION This is a basic wrapper for Github's API. =cut no indirect; use Future; use Dir::Self; use Path::Tiny; use File::ShareDir; use URI; use URI::QueryParam; use URI::Template; use JSON::MaybeXS; use Time::Moment; use Syntax::Keyword::Try; use Cache::LRU; use Ryu::Async; use Ryu::Observable; use Net::Async::WebSocket::Client; use Log::Any qw($log); use Net::Async::Github::Branch; use Net::Async::Github::User; use Net::Async::Github::Team; use Net::Async::Github::Plan; use Net::Async::Github::PullRequest; use Net::Async::Github::Repository; use Net::Async::Github::RateLimit; use Net::Async::Github::Comment; use JSON::MaybeUTF8 qw(:v2); =head1 METHODS =head2 current_user Returns information about the current user. my $user = $gh->current_user->get; printf "User [%s] has %d public repos and was last updated on %s%s\n", $user->login, $user->public_repos, $user->updated_at->to_string Resolves to a L instance. =cut sub current_user { my ($self, %args) = @_; $self->validate_args(%args); $self->http_get( uri => $self->endpoint('current_user') )->transform( done => sub { Net::Async::Github::User->new( %{$_[0]}, github => $self, ) } ) } =head2 configure Accepts the following optional named parameters: =over 4 =item * C - the Github API token =item * C - hashref of L-compliant URL mappings =item * C - an HTTP client compatible with the L API =item * C - the MIME type to use as the C header for requests =item * C - number of GET responses to cache. Defaults to 1000, set to 0 to disable. =item * C - How long in seconds to wait before giving up on a request. Defaults to 60. If set to 0, then no timeout will take place. =back B< You probably just want C >, defaults should be fine for the other settings. If you're creating a large number of instances, you can avoid some disk access overhead by passing C from an existing instance to the constructor for a new instance. =cut sub configure { my ($self, %args) = @_; for my $k (grep exists $args{$_}, qw(token endpoints api_key http base_uri mime_type page_cache_size timeout)) { $self->{$k} = delete $args{$k}; } $self->SUPER::configure(%args); } =head2 reopen Reopens the given PR. Expects the following named parameters: =over 4 =item * owner - which user or organisation owns this PR =item * repo - which repo it's for =item * id - the pull request ID =back Resolves to the current status. =cut sub reopen { my ($self, %args) = @_; die "needs $_" for grep !$args{$_}, qw(owner repo id); $self->validate_args(%args); my $uri = URI->new($self->base_uri); $uri->path( join '/', 'repos', $args{owner}, $args{repo}, 'pulls', $args{id} ); $self->http_patch( uri => $uri, data => { state => 'open', }, ) } =head2 pull_request Returns information about the given PR. Expects the following named parameters: =over 4 =item * owner - which user or organisation owns this PR =item * repo - which repo it's for =item * id - the pull request ID =back Resolves to the current status. =cut sub pull_request { my ($self, %args) = @_; die "needs $_" for grep !$args{$_}, qw(owner repo id); $self->validate_args(%args); my $uri = $self->base_uri; $uri->path( join '/', 'repos', $args{owner}, $args{repo}, 'pulls', $args{id} ); $log->tracef('Check Github pull request via URI %s', "$uri"); $self->http_get( uri => $uri, )->transform( done => sub { $log->tracef('Github PR data was ', $_[0]); Net::Async::Github::PullRequest->new( %{$_[0]}, github => $self, ) } ) } # Provide an alias for anyone relying on previous name *pr = *pull_request; =head2 pull_requests Returns information of all PRs of given repository. Expects the following named parameters: =over 4 =item * C - which user or organisation owns this PR =item * C - the repository this pull request is for =back Returns a L instance, this will emit a L instance for each found repository. =cut sub pull_requests { my ($self, %args) = @_; $self->validate_args(%args); $self->api_get_list( endpoint => 'pull_request', endpoint_args => { owner => $args{owner}, repo => $args{repo}, }, class => 'Net::Async::Github::PullRequest' ); } sub issue_comments { my ($self, %args) = @_; $self->validate_args(%args); $self->api_get_list( endpoint => 'issue_comments', endpoint_args => { owner => $args{owner}, repo => $args{repo}, }, class => 'Net::Async::Github::Comment' ); } # Provide an alias for anyone relying on previous name *prs = *pull_requests; sub teams { my ($self, %args) = @_; $self->validate_args(%args); $self->api_get_list( uri => $self->endpoint('team', org => $args{organisation}), class => 'Net::Async::Github::Team', ) } sub Net::Async::Github::Repository::forks { my ($self, %args) = @_; my $gh = $self->github; $gh->validate_args(%args); $gh->api_get_list( uri => $self->forks_url->process, class => 'Net::Async::Github::Repository', ) } sub Net::Async::Github::Repository::branches { my ($self, %args) = @_; my $gh = $self->github; $gh->validate_args(%args); $gh->api_get_list( uri => $self->branches_url->process, class => 'Net::Async::Github::Branch', ) } sub Net::Async::Github::Repository::grant_team { my ($self, %args) = @_; my $gh = $self->github; $gh->validate_args(%args); $self->github->http_put( uri => $self->github->endpoint( 'team_repo', team => $args{team}, owner => $self->owner->{login}, repo => $self->name, ), data => { permission => $args{permission}, }, ) } =head2 create_branch Creates a new branch. Takes the following named parameters: =over 4 =item * C - which organisation owns the target repository =item * C - the repository to raise the PR against =item * C - new branch name that will be created =item * C - the SHA1 value for this branch =back =cut sub create_branch { my ($self, %args) = @_; $self->validate_args(%args); $self->http_post( uri => $self->endpoint( 'git_refs_create', owner => $args{owner}, repo => $args{repo}, ), data => { ref => "refs/heads/$args{branch}", sha => $args{sha} }, ) } =head2 update_ref Update a reference to a new commit Takes the following named parameters: =over 4 =item * C - which organisation owns the target repository =item * C - the repository to raise the PR against =item * C - ref name that we are updating. =item * C - the SHA1 value of comment that the ref will point to =item * C - force update ref even if it is not fast-forward if it is true. =back =cut sub update_ref { my ($self, %args) = @_; $self->validate_args(%args); $self->http_patch( uri => $self->endpoint( 'git_refs', owner => $args{owner}, repo => $args{repo}, category => 'heads', ref => $args{ref}, ), data => { sha => $args{sha}, force => ($args{force} ? JSON->true : JSON->false) }, ) } =head2 create_pr Creates a new pull request. Takes the following named parameters: =over 4 =item * C - which organisation owns the target repository =item * C - the repository to raise the PR against =item * C - head commit starting point, typically the latest commit on your fork's branch =item * C - base commit this PR applies changes to typically you'd want the target repo C =back =cut sub create_pr { my ($self, %args) = @_; $self->validate_args(%args); $self->http_post( uri => $self->endpoint( 'pull_request', owner => $args{owner}, repo => $args{repo}, ), data => { head => $args{head}, base => $args{base}, title => $args{title}, $args{body} ? (body => $args{body}) : (), }, ) } =head2 create_commit Creates an empty commit. Can be used to simulate C or to create a merge commit from multiple heads. Takes the following named parameters: =over 4 =item * C - which organisation owns the target repository =item * C - the repository to raise the PR against =item * C - The commit message =item * C - The SHA of tree object that commit will point to =item * C - Arrayref that include the parents of the commit =back =cut sub create_commit { my ($self, %args) = @_; $self->validate_args(%args); $self->http_post( uri => $self->endpoint( 'commits', owner => $args{owner}, repo => $args{repo}, ), data => { message => $args{message}, tree => $args{tree}, parents => $args{parents}, }, ) } # Example: # # $repo->protect_branch( # branch => 'master', # required_status_checks => { # strict => 1, # contexts => [ # '', # ] # }, # enforce_admins => 0, # restrictions => { # teams => [ # 'WRITE-Admin', # ] # } sub Net::Async::Github::Repository::protect_branch { my ($self, %args) = @_; my $gh = $self->github; $gh->validate_args(%args); # Coƫrce the true/false values into something appropriate for JSON $args{required_status_checks} = { %{$args{required_status_checks}} }; $_->{strict} = $_->{strict} ? JSON->true : JSON->false for $args{required_status_checks}; $args{enforce_admins} = $args{enforce_admins} ? JSON->true : JSON->false; $args{required_pull_request_reviews} //= undef; if($args{restrictions} //= undef) { $args{restrictions}{users} ||= []; $args{restrictions}{teams} ||= []; } $self->github->http_put( uri => $self->github->endpoint( 'branch_protection', owner => $self->owner->{login}, repo => $self->name, branch => ($args{branch} // die 'need a branch'), ), data => { map {; $_ => $args{$_} } grep { exists $args{$_} } qw( required_status_checks enforce_admins required_pull_request_reviews restrictions ) }, ) } sub Net::Async::Github::Repository::branch_protection { my ($self, %args) = @_; my $gh = $self->github; $gh->validate_args(%args); $self->github->http_get( uri => $self->github->endpoint( 'branch_protection', owner => $self->owner->{login}, repo => $self->name, branch => ($args{branch} // die 'need a branch'), ), ) } sub Net::Async::Github::Repository::get_file { my ($self, %args) = @_; my $gh = $self->github; $gh->validate_args(%args); $self->github->http_get( uri => $self->github->endpoint( 'contents', owner => $self->owner->{login}, repo => $self->name, path => ($args{path} // die 'need a path'), (exists $args{branch} ? (branch => $args{branch}) : ()), ), )->transform( done => sub { my ($result) = @_; if($result->{encoding} eq 'base64') { return MIME::Base64::decode_base64($result->{content}) } else { return $result->{content} } } ) } sub Net::Async::Github::PullRequest::owner { shift->{base}{repo}{owner}{login} } sub Net::Async::Github::PullRequest::repo { shift->{base}{repo}{name} } sub Net::Async::Github::PullRequest::branch_name { shift->{head}{ref} } sub Net::Async::Github::PullRequest::merge { my ($self, %args) = @_; my $gh = $self->github; $gh->validate_args(%args); die 'invalid owner' if ref $self->owner; die 'invalid repo' if ref $self->repo; die 'invalid id' if ref $self->id; my $uri = $gh->endpoint( 'pull_request_merge', owner => $args{owner} // $self->owner, repo => $args{repo} // $self->repo, id => $args{id} // $self->number, ); $log->infof('URI for PR merge is %s', "$uri"); $gh->http_put( uri => $uri, data => { sha => $self->{head}{sha}, map { $_ => $args{$_} } grep { exists $args{$_} } qw( commit_title commit_message sha merge_method admin_override ) } ) } sub Net::Async::Github::PullRequest::cleanup { my ($self, %args) = @_; my $gh = $self->github; $gh->validate_args(%args); die 'invalid owner' if ref $self->owner; die 'invalid repo' if ref $self->repo; die 'invalid id' if ref $self->id; my $uri = $gh->endpoint( 'git_refs', category => 'heads', owner => $args{owner} // $self->{head}{repo}{owner}{login}, repo => $args{repo} // $self->{head}{repo}{name}, ref => $args{ref} // $self->branch_name, ); $log->infof('URI for PR delete is %s', "$uri"); $gh->http_delete( uri => $uri, ) } sub repos { my ($self, %args) = @_; if(my $user = delete $args{owner}) { $self->validate_owner_name($user); $self->api_get_list( endpoint => 'user_repositories', endpoint_args => { user => $user, visibility => $args{visibility} // 'all', }, class => 'Net::Async::Github::Repository', ) } else { $self->api_get_list( endpoint => 'current_user_repositories', endpoint_args => { visibility => $args{visibility} // 'all', }, class => 'Net::Async::Github::Repository', ) } } sub org_repos { my ($self, %args) = @_; if(my $user = delete $args{owner}) { $self->validate_owner_name($user); $self->api_get_list( endpoint => 'organization_repositories', endpoint_args => { org => $user, }, class => 'Net::Async::Github::Repository', ) } else { $self->api_get_list( endpoint => 'current_user_repositories', endpoint_args => { visibility => $args{visibility} // 'all', }, class => 'Net::Async::Github::Repository', ) } } sub repo { my ($self, %args) = @_; die 'need an owner name' unless my $owner = delete $args{owner}; die 'need a repo name' unless my $repo_name = delete $args{name}; $self->validate_owner_name($owner); $self->validate_repo_name($repo_name); $self->http_get( uri => $self->endpoint( repository => ( owner => $owner, repo => $repo_name, ) ), )->transform( done => sub { $log->tracef('Github repo data was %s', $_[0]); Net::Async::Github::Repository->new( %{$_[0]}, github => $self, ) } ) } =head2 user Returns information about the given user. =cut sub user { my ($self, $user, %args) = @_; $self->validate_owner_name($user); $self->http_get( uri => $self->endpoint( 'user', user => $user ), )->transform( done => sub { Net::Async::Github::User->new( %{$_[0]}, github => $self, ) } ) } =head2 users Iterates through all users. This is a good way to exhaust your 5000-query ratelimiting quota. =cut sub users { my ($self, %args) = @_; $self->validate_args(%args); $self->api_get_list( uri => '/users', class => 'Net::Async::Github::User', ) } sub users_for_org { my ($self, %args) = @_; $self->validate_args(%args); $self->api_get_list( uri => '/orgs/' . $args{owner} . '/members', class => 'Net::Async::Github::User', ) } =head2 head Identifies the head version for this branch. Requires the following named parameters: =over 4 =item * owner - which organisation or person owns the repo =item * repo - the repository name =item * branch - which branch to check =back =cut sub head { my ($self, %args) = @_; die "needs $_" for grep !$args{$_}, qw(owner repo branch); $self->validate_args(%args); my $uri = $self->base_uri; $uri->path( join '/', 'repos', $args{owner}, $args{repo}, qw(git refs heads), $args{branch} ); $self->http_get( uri => $uri ) } =head2 update =cut sub update { my ($self, %args) = @_; die "needs $_" for grep !$args{$_}, qw(owner repo branch head); $self->validate_branch_name($args{branch}); my $uri = $self->base_uri; $uri->path( join '/', 'repos', $args{owner}, $args{repo}, qw(merges) ); $self->http_post( uri => $uri, data => { head => $args{head}, base => $args{branch}, commit_message => "Merge branch 'master' into " . $args{branch}, }, ) } =head2 core_rate_limit Returns a L instance which can track rate limits. =cut sub core_rate_limit { my ($self) = @_; $self->{core_rate_limit} //= do { use Variable::Disposition qw(retain_future); use namespace::clean qw(retain_future); my $rl = Net::Async::Github::RateLimit::Core->new( limit => Ryu::Observable->new(undef), remaining => Ryu::Observable->new(undef), reset => Ryu::Observable->new(undef), ); retain_future( $self->http_get( uri => $self->endpoint('rate_limit') )->on_done(sub { my $data = shift; $log->tracef("Github rate limit response was %s", $data); $rl->reset->set_numeric($data->{resources}{core}{reset}); $rl->limit->set_numeric($data->{resources}{core}{limit}); $rl->remaining->set_numeric($data->{resources}{core}{remaining}); }) ); $rl; } } =head2 rate_limit =cut sub rate_limit { my ($self) = @_; $self->http_get( uri => $self->endpoint('rate_limit') )->transform( done => sub { Net::Async::Github::RateLimit->new( %{$_[0]} ) } ) } =head1 METHODS - Internal The following methods are used internally. They're not expected to be useful for external callers. =head2 api_key =cut sub api_key { shift->{api_key} } =head2 token =cut sub token { shift->{token} } =head2 endpoints Returns an accessor for the endpoints data. This is a hashref containing URI templates, used by L. =cut sub endpoints { my ($self) = @_; $self->{endpoints} ||= do { my $path = Path::Tiny::path(__DIR__)->parent(3)->child('share/endpoints.json'); $path = Path::Tiny::path( File::ShareDir::dist_file( 'Net-Async-Github', 'endpoints.json' ) ) unless $path->exists; decode_json_text($path->slurp_utf8) }; } =head2 endpoint Expands the selected URI via L. Each item is defined in our C< endpoints.json > file. Returns a L instance. =cut sub endpoint { my ($self, $endpoint, %args) = @_; URI::Template->new( $self->endpoints->{$endpoint . '_url'} )->process(%args); } =head2 http Accessor for the HTTP client object. Will load and instantiate a L instance if necessary. Actual HTTP implementation is not guaranteed, and the default is likely to change in future. =cut sub http { my ($self) = @_; $self->{http} ||= do { require Net::Async::HTTP; $self->add_child( my $ua = Net::Async::HTTP->new( fail_on_error => 1, max_connections_per_host => $self->connections_per_host, pipeline => 1, max_in_flight => 4, decode_content => 1, user_agent => 'Mozilla/4.0 (perl; Net::Async::Github; TEAM@cpan.org)', ( $self->timeout ? (timeout => $self->timeout) : () ), ) ); $ua } } sub update_limiter { my ($self) = @_; unless($self->{update_limiter}) { # Any modification should wait for this to resolve first $self->{update_limiter} = $self->loop->delay_future( after => 1 )->on_ready(sub { delete $self->{update_limiter} }); # Limit the next request - not this one return Future->done; } return $self->{update_limiter}; } # Github ratelimit guidelines suggest max 1 request in parallel # per user, with 1s between any state-modifying calls. Since this # is part of their defined API, we don't expose this in L. sub connections_per_host { 4 } # Like connections, but for data modification - POST, PUT, PATCH etc. sub updates_per_host { 1 } =head2 timeout The parameter that will be used when create Net::Async::HTTP object. If it is undef, then a default value 60 seconds will be used. If it is 0, then Net::Async::HTTP will never timeout. =cut sub timeout { shift->{timeout} //= 60 } =head2 auth_info Returns authentication information used in the HTTP request. =cut sub auth_info { my ($self) = @_; if(my $key = $self->api_key) { return ( user => $key, pass => '', ); } if(my $token = $self->token) { return ( headers => { Authorization => 'token ' . $token } ) } die "need some form of auth, try passing a token or api_key" } =head2 mime_type Returns the MIME type used for requests. Currently defined by github in L as C. =cut sub mime_type { shift->{mime_type} //= 'application/vnd.github.v3+json' } =head2 base_uri The L for requests. Defaults to L. =cut sub base_uri { ( shift->{base_uri} //= URI->new('https://api.github.com') )->clone } =head2 http_get Performs an HTTP GET request. =cut sub http_get { my ($self, %args) = @_; my %auth = $self->auth_info; if(my $hdr = delete $auth{headers}) { $args{headers}{$_} //= $hdr->{$_} for keys %$hdr } $args{$_} //= $auth{$_} for keys %auth; my $uri = delete $args{uri}; $log->tracef("GET %s { %s }", $uri->as_string, \%args); my $cached = $self->page_cache->get($uri->as_string); if($cached) { $log->tracef("Had cached page data, etag %s and last modified %s", $cached->header('ETag'), $cached->header('Last-Modified')); $args{headers}{'If-None-Match'} = $cached->header('ETag') if $cached->header('ETag'); $args{headers}{'If-Modified-Since'} = $cached->header('Last-Modified') if $cached->header('Last-Modified'); } $self->http->GET( $uri, %args, )->on_fail(sub { $log->tracef('Response failed for %s', "$uri"); })->on_cancel(sub { $log->tracef('Request cancelled for %s', "$uri"); })->on_done(sub { $log->tracef('Response received for %s', "$uri"); })->then(sub { my ($resp) = @_; $log->tracef("Github response: %s", $resp->as_string("\n")); # If we had ratelimiting headers, apply them for my $k (qw(Reset Limit Remaining)) { if(defined(my $v = $resp->header('X-RateLimit-' . $k))) { my $method = lc $k; $self->core_rate_limit->$method->set_numeric($v); } } if($cached && $resp->code == 304) { $resp = $cached; $log->tracef("Using cached version of [%s] for %d byte response", $uri->as_string, $resp->content_length); } elsif($resp->is_success) { $log->tracef("Caching [%s] with %d byte response", $uri->as_string, $resp->content_length); $self->page_cache->set($uri->as_string => $resp); } else { $log->tracef("Not caching [%s] due to status %d", $resp->code); } return Future->done( { }, $resp ) if $resp->code == 204; return Future->done( { }, $resp ) if 3 == ($resp->code / 100); try { return Future->done( decode_json_utf8( $resp->decoded_content ), $resp ); } catch { $log->errorf("JSON decoding error %s from HTTP response %s", $@, $resp->as_string("\n")); return Future->fail($@ => json => $resp); } })->else(sub { my ($err, $src, $resp, $req) = @_; $log->warnf("Github failed with error %s on source %s", $err, $src); $src //= ''; if($src eq 'http') { $log->errorf("HTTP error %s, request was %s with response %s", $err, $req->as_string("\n"), $resp->as_string("\n")); } else { $log->errorf("Other failure (%s): %s", $src // 'unknown', $err); } Future->fail(@_); }) } sub http_delete { my ($self, %args) = @_; my %auth = $self->auth_info; if(my $hdr = delete $auth{headers}) { $args{headers}{$_} //= $hdr->{$_} for keys %$hdr } $args{$_} //= $auth{$_} for keys %auth; my $uri = delete $args{uri}; $log->tracef("DELETE %s { %s }", $uri->as_string, \%args); # we never cache deletes $self->http->do_request( method => 'DELETE', uri => $uri, %args, )->then(sub { my ($resp) = @_; $log->tracef("Github response: %s", $resp->as_string("\n")); # If we had ratelimiting headers, apply them for my $k (qw(Reset Limit Remaining)) { if(defined(my $v = $resp->header('X-RateLimit-' . $k))) { my $method = lc $k; $self->core_rate_limit->$method->set_numeric($v); } } return Future->done( { }, $resp ) if $resp->code == 204; return Future->done( { }, $resp ) if 3 == ($resp->code / 100); try { return Future->done( decode_json_utf8( $resp->decoded_content ), $resp ); } catch { $log->errorf("JSON decoding error %s from HTTP response %s", $@, $resp->as_string("\n")); return Future->fail($@ => json => $resp); } })->else(sub { my ($err, $src, $resp, $req) = @_; $log->warnf("Github failed with error %s on source %s", $err, $src); $src //= ''; if($src eq 'http') { $log->errorf("HTTP error %s, request was %s with response %s", $err, $req->as_string("\n"), $resp->as_string("\n")); } else { $log->errorf("Other failure (%s): %s", $src // 'unknown', $err); } Future->fail(@_); }) } sub http_put { my ($self, %args) = @_; my %auth = $self->auth_info; my $method = delete $args{method} || 'PUT'; if(my $hdr = delete $auth{headers}) { $args{headers}{$_} //= $hdr->{$_} for keys %$hdr } $args{$_} //= $auth{$_} for keys %auth; my $uri = delete $args{uri}; my $data = delete $args{data}; $log->tracef("%s %s { %s } <= %s", $method, $uri->as_string, \%args, $data); $data = encode_json_utf8($data) if ref $data; $self->http->do_request( method => $method, uri => $uri, content => $data, content_type => 'application/json', %args, )->then(sub { my ($resp) = @_; $log->tracef("Github response: %s", $resp->as_string("\n")); # If we had ratelimiting headers, apply them for my $k (qw(Limit Remaining Reset)) { if(defined(my $v = $resp->header('X-RateLimit-' . $k))) { my $method = lc $k; $self->core_rate_limit->$method->set_numeric($v); } } return Future->done( { }, $resp ) if $resp->code == 204; return Future->done( { }, $resp ) if 3 == ($resp->code / 100); try { return Future->done( decode_json_utf8( $resp->decoded_content ), $resp ); } catch { $log->errorf("JSON decoding error %s from HTTP response %s", $@, $resp->as_string("\n")); return Future->fail($@ => json => $resp); } })->else(sub { my ($err, $src, $resp, $req) = @_; $log->warnf("Github failed with error %s on source %s", $err, $src); $src //= ''; if($src eq 'http') { $log->errorf("HTTP error %s, request was %s with response %s", $err, $req->as_string("\n"), $resp->as_string("\n")); } else { $log->errorf("Other failure (%s): %s", $src // 'unknown', $err); } Future->fail(@_); }) } sub http_patch { my ($self, %args) = @_; return $self->http_put(%args, method => 'PATCH'); } sub http_post { my ($self, %args) = @_; my %auth = $self->auth_info; if(my $hdr = delete $auth{headers}) { $args{headers}{$_} //= $hdr->{$_} for keys %$hdr } $args{$_} //= $auth{$_} for keys %auth; my $uri = delete $args{uri}; my $data = delete $args{data}; $log->tracef("POST %s { %s } <= %s", $uri->as_string, \%args, $data); $data = encode_json_utf8($data) if ref $data; $self->http->POST( $uri, $data, content_type => 'application/json', %args, )->then(sub { my ($resp) = @_; $log->tracef("Github response: %s", $resp->as_string("\n")); # If we had ratelimiting headers, apply them for my $k (qw(Limit Remaining Reset)) { if(defined(my $v = $resp->header('X-RateLimit-' . $k))) { my $method = lc $k; $self->core_rate_limit->$method->set_numeric($v); } } return Future->done( { }, $resp ) if $resp->code == 204; return Future->done( { }, $resp ) if 3 == ($resp->code / 100); try { return Future->done( decode_json_utf8( $resp->decoded_content ), $resp ); } catch { $log->errorf("JSON decoding error %s from HTTP response %s", $@, $resp->as_string("\n")); return Future->fail($@ => json => $resp); } })->else(sub { my ($err, $src, $resp, $req) = @_; $log->warnf("Github failed with error %s on source %s", $err, $src); $src //= ''; if($src eq 'http') { $log->errorf("HTTP error %s, request was %s with response %s", $err, $req->as_string("\n"), $resp->as_string("\n")); } else { $log->errorf("Other failure (%s): %s", $src // 'unknown', $err); } Future->fail(@_); }) } sub api_get_list { use Variable::Disposition qw(retain_future); use Scalar::Util qw(refaddr); use Future::Utils qw(fmap0); use namespace::clean qw(retain_future fmap0 refaddr); my ($self, %args) = @_; my $label = $args{endpoint} ? ('Github[' . $args{endpoint} . ']') : (caller 1)[3]; die "Must be a member of a ::Loop" unless $self->loop; # Hoist our HTTP API call into a source of items my $src = $self->ryu->source( label => $label ); my $uri = $args{endpoint} ? $self->endpoint( $args{endpoint}, %{$args{endpoint_args}} ) : ref $args{uri} ? $args{uri} : URI->new( $self->base_uri . delete($args{uri}) ); my $per_page = (delete $args{per_page}) || 100; $uri->query_param( limit => $per_page ); my @pending = $uri; my $f = (fmap0 { my $uri = shift; $self->http_get( uri => $uri, )->on_done(sub { my ($data, $resp) = @_; # Handle paging - this takes the form of zero or more Link headers like this: # Link: ; rel="next" for my $link (map { split /\s*,\s*/, $_ } $resp->header('Link')) { if($link =~ m{<([^>]+)>; rel="next"}) { push @pending, URI->new($1); } } $src->emit( $args{class}->new( %$_, ($args{extra} ? %{$args{extra}} : ()), github => $self ) ) for @{ $_[0] }; })->on_fail(sub { warn "fail - @_"; $src->fail(@_) })->on_cancel(sub { warn "cancel - @_"; $src->cancel }); } foreach => \@pending)->on_done(sub { $src->finish; }); # If our source finishes earlier than our HTTP request, then cancel the request $src->completed->on_ready(sub { return if $f->is_ready; $log->tracef("Finishing HTTP request early for %s since our source is no longer active", $label); $f->cancel }); # Track active requests my $refaddr = Scalar::Util::refaddr($f); $self->pending_requests->push([ { id => $refaddr, src => $src, uri => $uri, future => $f, } ])->then(sub { $f->on_ready(sub { retain_future( $self->pending_requests->extract_first_by(sub { $_->{id} == $refaddr }) ) }); })->retain; $src } =head2 pending_requests A list of all pending requests. =cut sub pending_requests { shift->{pending_requests} //= do { require Adapter::Async::OrderedList::Array; Adapter::Async::OrderedList::Array->new } } =head2 validate_branch_name Applies validation rules from L for a branch name. Will raise an exception on invalid input. =cut sub validate_branch_name { my ($self, $branch) = @_; die "branch not defined" unless defined $branch; die "branch contains path component with leading ." if $branch =~ m{/\.}; die "branch contains double ." if $branch =~ m{\.\.}; die "branch contains invalid character(s)" if $branch =~ m{[[:cntrl:][:space:]~^:\\]}; die "branch ends with /" if substr($branch, -1) eq '/'; die "branch ends with .lock" if substr($branch, -5) eq '.lock'; return 1; } =head2 validate_owner_name Applies github rules for user/organisation name. Will raise an exception on invalid input. =cut sub validate_owner_name { my ($self, $owner) = @_; die "owner name not defined" unless defined $owner; die "owner name too long" if length($owner) > 39; die "owner name contains invalid characters" if $owner =~ /[^a-z0-9-]/i; die "owner name contains double hyphens" if $owner =~ /--/; die "owner name contains leading hyphen" if $owner =~ /^-/; die "owner name contains trailing hyphen" if $owner =~ /-$/; return 1; } =head2 validate_repo_name Applies github rules for repository name. Will raise an exception on invalid input. =cut sub validate_repo_name { my ($self, $repo) = @_; die "repo name not defined" unless defined $repo; # Not really as well-defined as I'd like, closest to an official answer seems to be here: # https://github.community/t/github-repository-name-vs-description-vs-readme-heading-h1/3284 # There are repositories with underscores, but that seems to be strongly discouraged: # https://github.com/Automattic/_s # Canonical repositories with '. character would include the `.wiki` "magic" repo for each # Github repo die "repo name contains invalid characters" if $repo =~ /[^a-z0-9._-]/i; die "repo name too long" if length($repo) > 100; return 1; } =head2 validate_args Convenience method to apply validation on common parameters. =cut sub validate_args { my ($self, %args) = @_; $self->validate_branch_name($args{branch}) if exists $args{branch}; $self->validate_owner_name($args{owner}) if exists $args{owner}; $self->validate_repo_name($args{repo}) if exists $args{repo}; } =head2 page_cache_size Returns the total number of GET responses we'll cache. Default is probably 1000. =cut sub page_cache_size { shift->{page_cache_size} //= 1000 } =head2 page_cache The page cache instance, likely to be provided by L. =cut sub page_cache { $_[0]->{page_cache} //= do { Cache::LRU->new( size => $_[0]->page_cache_size ) } } =head2 ryu Our L instance, used for instantiating L instances. =cut sub ryu { shift->{ryu} } sub _add_to_loop { my ($self, $loop) = @_; # Hand out sources and sinks $self->add_child( $self->{ryu} = Ryu::Async->new ); } sub ws { my ($self) = @_; $self->{ws} // do { require Net::Async::WebSocket::Client; $self->add_child( my $ws = Net::Async::WebSocket::Client->new( on_frame => $self->curry::weak::on_frame, ) ); Scalar::Util::weaken($self->{ws} = $ws); $ws }; } 1; =head1 AUTHOR Tom Molesworth , with contributions from C<< @chylli-binary >>. =head1 LICENSE Copyright Tom Molesworth 2014-2021. Licensed under the same terms as Perl itself.