From 5b2b9fb6849e7be4e82e255cf053b309de1dd5c1 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Fri, 24 Apr 2026 22:37:35 +0900 Subject: [PATCH 01/26] Add a new config module, based on the one for app_2017, with two new actions --- lib/pause_2026/PAUSE/Web2026/Config.pm | 49 ++++++++++++++++++++++++++ 1 file changed, 49 insertions(+) create mode 100644 lib/pause_2026/PAUSE/Web2026/Config.pm diff --git a/lib/pause_2026/PAUSE/Web2026/Config.pm b/lib/pause_2026/PAUSE/Web2026/Config.pm new file mode 100644 index 00000000..9688ce8b --- /dev/null +++ b/lib/pause_2026/PAUSE/Web2026/Config.pm @@ -0,0 +1,49 @@ +package PAUSE::Web2026::Config; + +use Mojo::Base "PAUSE::Web::Config"; + +my %new_actions = ( + list_tokens => { + x_mojo_to => "user-tokens#list", + verb => "List Tokens", + priv => "user", + cat => "User/06Account/03", + desc => "Manage your tokens for client scripts.", + method => 'POST', + x_csrf_protection => 1, + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + revoke_tokens_sub => {form_type => "submit_button"}, + revoke_tokens => {form_type => "check_box"}, + } + }, + new_token => { + x_mojo_to => "user-tokens#generate", + verb => "Generate a New Token", + priv => "user", + cat => "User/06Account/04", + desc => "Generate a new token for client scripts.", + method => 'POST', + x_csrf_protection => 1, + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + new_token_description => {form_type => "text_field"}, + new_token_scope => {form_type => "select_field"}, + new_token_expires_in => {form_type => "text_field"}, + new_token_ip_ranges => {form_type => "text_area"}, + new_token_sub => {form_type => "submit_button"}, + }, + }, + pause_logout => { + x_mojo_to => "user#pause_logout", + verb => "About Logging Out", + priv => "user", + cat => "User/06Account/05", + }, +); + +%PAUSE::Web::Config::Actions = ( %PAUSE::Web::Config::Actions, %new_actions ); + +push @PAUSE::Web::Config::AllowAdminTakeover, "list_tokens"; + +1; From 1e988af43cd2c9199fda84f2f6c8dec93186bb0d Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Fri, 24 Apr 2026 22:37:59 +0900 Subject: [PATCH 02/26] Add a new web context module, based on the one for app_2017 --- lib/pause_2026/PAUSE/Web2026/Context.pm | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 lib/pause_2026/PAUSE/Web2026/Context.pm diff --git a/lib/pause_2026/PAUSE/Web2026/Context.pm b/lib/pause_2026/PAUSE/Web2026/Context.pm new file mode 100644 index 00000000..3c6872c6 --- /dev/null +++ b/lib/pause_2026/PAUSE/Web2026/Context.pm @@ -0,0 +1,10 @@ +package PAUSE::Web2026::Context; + +use Mojo::Base "PAUSE::Web::Context"; + +has config => sub { require PAUSE::Web2026::Config; PAUSE::Web2026::Config->new }; +has template_paths => sub { [ "lib/pause_2017/templates", "lib/pause_2026/templates" ] }; +has controller_namespaces => sub { [ "PAUSE::Web::Controller", "PAUSE::Web2026::Controller" ] }; + +1; + From eea0b3488051301fbee34982f8d0afe734e5d84f Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Fri, 24 Apr 2026 22:43:58 +0900 Subject: [PATCH 03/26] Add a controller for the new actions --- .../PAUSE/Web2026/Controller/User/Tokens.pm | 110 ++++++++++++++++++ 1 file changed, 110 insertions(+) create mode 100644 lib/pause_2026/PAUSE/Web2026/Controller/User/Tokens.pm diff --git a/lib/pause_2026/PAUSE/Web2026/Controller/User/Tokens.pm b/lib/pause_2026/PAUSE/Web2026/Controller/User/Tokens.pm new file mode 100644 index 00000000..658cb259 --- /dev/null +++ b/lib/pause_2026/PAUSE/Web2026/Controller/User/Tokens.pm @@ -0,0 +1,110 @@ +package PAUSE::Web2026::Controller::User::Tokens; + +use Mojo::Base "Mojolicious::Controller"; +use HTTP::Date (); +use File::pushd; +use PAUSE (); +use Crypt::PRNG; +use Digest::SHA; + +sub list { + my $c = shift; + my $pause = $c->stash(".pause"); + my $req = $c->req; + my $mgr = $c->app->pause; + my $u = $c->active_user_record; + + my $dbh = $mgr->authen_connect; + + if ($req->param('revoke_tokens_sub')) { + my $sth_update = $dbh->prepare('UPDATE auth_tokens SET revoked = 1 WHERE id = ? AND user = ?'); + my $sth_select = $dbh->prepare('SELECT user, token_id, revoked FROM auth_tokens WHERE id = ?'); + for my $id (@{$req->every_param('revoke_tokens')}) { + $sth_select->execute($id); + my $target = $sth_select->fetchrow_hashref; + if ($target) { + my $token_id = $target->{token_id}; + my $is_revoked = $sth_update->execute($id, $u->{userid}); + if ($is_revoked) { + $mgr->log({level => 'info', message => "Revoked a token $token_id for $u->{userid}"}); + } else { + if ($target->{revoked}) { + $mgr->log({level => 'warn', message => "Failed to revoke a token $token_id for $u->{userid}: already revoked"}); + } elsif ($target->{userid} ne $u->{userid}) { + $mgr->log({level => 'error', message => "Failed to revoke a token $token_id for $u->{userid}: wrong userid"}); + } + } + } else { + $mgr->log({level => 'warn', message => "Failed to revoke a token for $u->{userid}: unknown token"}); + } + } + } + + my $tokens = $dbh->selectall_arrayref(qq{ + SELECT id, token_id, description, expires_at + FROM auth_tokens + WHERE user = ? AND revoked = 0 ORDER BY created_at DESC + }, {Slice => +{}}, $u->{userid}); + + $pause->{tokens} = $tokens; +} + +sub generate { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + my $u = $c->active_user_record; + + if ($req->param('new_token_sub')) { + my $token = Crypt::PRNG::random_bytes_hex(32); + my $token_id = Crypt::PRNG::random_bytes_hex(4); + my $token_hash = Digest::SHA::hmac_sha256_hex($token, $token_id); + my $description = $req->param('new_token_description'); + my $expires_in = $req->param('new_token_expires_in') || 180; + my $ip_ranges = $req->param('new_token_ip_ranges'); + + # right now we have only one scope + my $scope = 'upload:distributions'; + + my $expires_at = time; + $expires_in += 0; + $expires_in = 1 if $expires_in < 1; + $expires_in = 180 if $expires_in > 180; + $expires_at += int($expires_in) * 24 * 60 * 60; + + if ($ip_ranges) { + require Net::CIDR; + my @ip_errors; + # TODO: how many CIDRs should we accept? + for my $ip (split /\n/, $ip_ranges) { + if (!Net::CIDR::cidrvalidate($ip)) { + push @ip_errors, $ip; + } + } + if (@ip_errors) { + $pause->{error}{ip_ranges_error} = join "; ", @ip_errors; + } + } + if (!$pause->{error}) { + my $dbh = $mgr->authen_connect; + my $is_inserted = $dbh->do(qq{ + INSERT INTO auth_tokens + (user, token_id, token_hash, description, expires_at, scope, ip_ranges) + VALUES (?, ?, ?, ?, ?, ?, ?) + }, undef, $u->{userid}, $token_id, $token_hash, $description, Time::Piece->new($expires_at)->strftime('%Y-%m-%d %H:%M:%S'), $scope, $ip_ranges); + if ($is_inserted) { + $mgr->log({level => 'info', message => "Generated a new token $token_id for $c->{userid}"}); + $c->flash(new_token => join ':', $u->{userid}, $token_id, $token); + return $c->redirect_to($c->my_url); + } else { + $pause->{error}{generation_failed} = 1; + } + } + for my $key (qw(description scope expires_at ip_ranges)) { + $pause->{$key} = $req->param("pause_99_new_token_$key"); + } + } +} + +1; From faa05482437bfa9d515e49691554b251dfe9c2e1 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Fri, 24 Apr 2026 22:44:16 +0900 Subject: [PATCH 04/26] Add templates for the new actions --- .../templates/user/tokens/generate.html.ep | 62 +++++++++++++++++++ .../templates/user/tokens/list.html.ep | 46 ++++++++++++++ 2 files changed, 108 insertions(+) create mode 100644 lib/pause_2026/templates/user/tokens/generate.html.ep create mode 100644 lib/pause_2026/templates/user/tokens/list.html.ep diff --git a/lib/pause_2026/templates/user/tokens/generate.html.ep b/lib/pause_2026/templates/user/tokens/generate.html.ep new file mode 100644 index 00000000..1fec0247 --- /dev/null +++ b/lib/pause_2026/templates/user/tokens/generate.html.ep @@ -0,0 +1,62 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; +% my $cpan_alias = lc($pause->{HiddenUser}{userid}) . '@cpan.org'; + + + +

Generate a new token for <%= $pause->{HiddenUser}{userid} %> +% if (exists $pause->{UserGroups}{admin}) { + (lastvisit <%= $pause->{HiddenUser}{lastvisit} || "before 2005-12-02" %>) +% } +

+ +% if (my $new_token = flash('new_token')) { +
+The generated token is <%= $new_token %>. This will never be shown again, so save it in a safe place. +
+% } else { + +% if (my $error = $pause->{error}) { +
+Token generation failed due to an error: +% if ($error->{ip_ranges_error}) { +invalid IP ranges: <%= $error->{ip_ranges_error} %> +% } elsif ($error->{generation_failed}) { +insertion failure (because of token duplication or other database error) +% } +
+% } + +
+

All fields are optional.

+ +% my $alter = 0; + + + + + + +

Token description

+

+

+<%= text_field "new_token_description", + size => 50, + maxlength => 127, # caution! +%> +

Token expires in

+

+

+<%= text_field "new_token_expires_in", + size => 3, + maxlength => 3, +%> days (default: 180) +

IP Ranges

+<%= text_area "new_token_ip_ranges", + rows => 5, +%> +
+%= csrf_field + + +% } diff --git a/lib/pause_2026/templates/user/tokens/list.html.ep b/lib/pause_2026/templates/user/tokens/list.html.ep new file mode 100644 index 00000000..5a16520f --- /dev/null +++ b/lib/pause_2026/templates/user/tokens/list.html.ep @@ -0,0 +1,46 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; +% my $tokens = $pause->{tokens} || []; + + +

Tokens for <%= $pause->{HiddenUser}{userid} %>

+ +% if (@$tokens) { +
+

+ + + + + + + + + + +% for my $token (@$tokens) { + + + + + + +% } + +
Token IDDescriptionExpires at
<%= check_box "revoke_tokens" => $token->{id} %><%= $token->{token_id} %><%= $token->{description} %><%= $token->{expires_at} %>
+ +

+
+%= csrf_field +% content_for javascript => begin +%= javascript "/list.min.js" +%= javascript begin +var List = new List('files', { + valueNames: ['token', 'description', 'expires_at'] +}); +% end +% end + +% } else { +No tokens for <%= $pause->{HiddenUser}{userid} %> +% } From 8d0512b5550e7dc1207e143135feda4fca835867 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Fri, 24 Apr 2026 22:48:24 +0900 Subject: [PATCH 05/26] Add an API application, based on PAUSE::Web --- lib/pause_2026/PAUSE/API.pm | 88 +++++++++++++++++++++++++++++++++++++ 1 file changed, 88 insertions(+) create mode 100644 lib/pause_2026/PAUSE/API.pm diff --git a/lib/pause_2026/PAUSE/API.pm b/lib/pause_2026/PAUSE/API.pm new file mode 100644 index 00000000..5075e6ce --- /dev/null +++ b/lib/pause_2026/PAUSE/API.pm @@ -0,0 +1,88 @@ +package PAUSE::API; + +use Mojo::Base "Mojolicious"; +use MojoX::Log::Dispatch::Simple; +use HTTP::Status qw/:constants status_message/; +use JSON; + +has pause => sub { Carp::confess "requires PAUSE::API::Context" }; + +sub startup { + my $app = shift; + + $app->moniker("pause-api"); + + $app->max_request_size(0); # indefinite upload size + + # Set the same logger as the one Plack uses + # (initialized in app.psgi) + $app->log(MojoX::Log::Dispatch::Simple->new( + dispatch => $app->pause->logger, + level => "debug", + )); + + $app->hook(around_dispatch => \&_log); + $app->hook(around_dispatch => \&_wrap); + + # Set random secrets to keep mojo session secure + $app->secrets($app->pause->secrets); + + $app->routes->namespaces($app->pause->controller_namespaces); + + # Check HTTP headers and set stash + my $r = $app->routes->under("/")->to("root#check", format => 'json'); + + my $requires_token = $r->under("/")->to("root#check_token", format => 'json'); + + $requires_token->post("/upload")->to("upload#upload", format => 'json'); +} + +sub _log { + my ($next, $c) = @_; + local $SIG{__WARN__} = sub { + my $message = shift; + chomp $message; + Log::Dispatch::Config->instance->log( + level => 'warn', + message => $message, + ); + }; + $c->helpers->reply->exception($@) unless eval { $next->(); 1 }; +} + +sub _wrap { + my ($next, $c, $action, $last) = @_; + + my $pause = $c->stash(".pause"); + if (!$pause) { + $pause = {}; + $c->stash(".pause", $pause); + } + + my $res = eval { $next->(); }; + if (my $e = $@) { + if (UNIVERSAL::isa($e, "PAUSE::Web::Exception")) { + if ($e->{ERROR}) { + $e->{ERROR} = [ $e->{ERROR} ] unless ref $e->{ERROR} eq 'ARRAY'; + push @{$pause->{ERROR}}, map { s/\s\s+/ /sgr } @{$e->{ERROR}}; + require Data::Dumper; + my $message = "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([$pause->{ERROR}],[qw(error)])->Indent(1)->Useqq(1)-> +Dump; + $c->app->pause->log({level => 'debug', message => $message}); + $c->res->code($e->{HTTP_STATUS} // HTTP_BAD_REQUEST); + return $c->render(json => { error => $pause->{ERROR} }) + } elsif ($e->{HTTP_STATUS}) { + return $c->render(json => {error => status_message($e->{HTTP_STATUS})}); + } + } else { + # this is NOT a known error type, we need to handle it anon + my $error = "$e"; + $c->app->pause->log({level => 'error', message => $error }); + $c->res->code(HTTP_INTERNAL_SERVER_ERROR); + return $c->render(json => {error => 'Internal server error'}); + } + } + return $res; +} + +1; From 76370b5b582f41819fc1b630fb50f980c1b534ed Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Fri, 24 Apr 2026 22:49:05 +0900 Subject: [PATCH 06/26] Add a context for the API app --- lib/pause_2026/PAUSE/API/Context.pm | 11 +++++++++++ 1 file changed, 11 insertions(+) create mode 100644 lib/pause_2026/PAUSE/API/Context.pm diff --git a/lib/pause_2026/PAUSE/API/Context.pm b/lib/pause_2026/PAUSE/API/Context.pm new file mode 100644 index 00000000..40f496e1 --- /dev/null +++ b/lib/pause_2026/PAUSE/API/Context.pm @@ -0,0 +1,11 @@ +package PAUSE::API::Context; + +use Mojo::Base "PAUSE::Web::Context"; + +has config => sub {}; +has template_paths => sub { [] }; +has controller_namespaces => sub { ["PAUSE::API::Controller"] }; + +1; + + From 32a53a7dc49e5c92f2990a73cf0010b8af2bbd3d Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Fri, 24 Apr 2026 22:50:35 +0900 Subject: [PATCH 07/26] Add a Root controller for the API --- lib/pause_2026/PAUSE/API/Controller/Root.pm | 39 +++++++++++++++++++++ 1 file changed, 39 insertions(+) create mode 100644 lib/pause_2026/PAUSE/API/Controller/Root.pm diff --git a/lib/pause_2026/PAUSE/API/Controller/Root.pm b/lib/pause_2026/PAUSE/API/Controller/Root.pm new file mode 100644 index 00000000..e7337d80 --- /dev/null +++ b/lib/pause_2026/PAUSE/API/Controller/Root.pm @@ -0,0 +1,39 @@ +package PAUSE::API::Controller::Root; + +use Mojo::Base "Mojolicious::Controller"; +use HTTP::Date (); +use Time::Duration (); +use PAUSE; + +sub check { + my $c = shift; + + if (my $res = _pause_is_closed()) { + $c->render(json => $res, status => 503); + return; + } + + return 1; +} + +sub _pause_is_closed { + my $dti = PAUSE::downtimeinfo(); + my $downtime = $dti->{downtime}; + my $willlast = $dti->{willlast}; + + # TODO: just ignore scheduled downtime for now + if (time >= $downtime && time < $downtime + $willlast) { + my $delta = $downtime + $willlast - time; + my $expr = Time::Duration::duration($delta); + my $willlast_dur = Time::Duration::duration($willlast); + return { + closed => { + delta => $expr, + will_last => $willlast_dur, + } + }; + } + return; +} + +1; From 251788c46aa2b1be3ab8d9a63f56cc227215a72c Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Fri, 24 Apr 2026 22:53:32 +0900 Subject: [PATCH 08/26] Add check_token action to Root --- lib/pause_2026/PAUSE/API/Controller/Root.pm | 92 +++++++++++++++++++++ 1 file changed, 92 insertions(+) diff --git a/lib/pause_2026/PAUSE/API/Controller/Root.pm b/lib/pause_2026/PAUSE/API/Controller/Root.pm index e7337d80..603fb52f 100644 --- a/lib/pause_2026/PAUSE/API/Controller/Root.pm +++ b/lib/pause_2026/PAUSE/API/Controller/Root.pm @@ -4,6 +4,7 @@ use Mojo::Base "Mojolicious::Controller"; use HTTP::Date (); use Time::Duration (); use PAUSE; +use Digest::SHA; sub check { my $c = shift; @@ -36,4 +37,95 @@ sub _pause_is_closed { return; } +sub check_token { + my $c = shift; + my $header = $c->req->headers->header('Authorization'); + die PAUSE::Web::Exception->new(ERROR => 'No authorization header') unless $header; + $header =~ s/Bearer\s+//i or die PAUSE::Web::Exception->new(ERROR => 'No Bearer token'); + + my ($user, $token_id, $token) = split ':', $header; + die PAUSE::Web::Exception->new(ERROR => 'Invalid token') if !$user or !$token_id or !$token; + + my $pause = $c->stash('.pause'); + if (!$pause) { + $c->stash(".pause" => $pause = {}); + } + + my $mgr = $c->app->pause; + my $dbh = $mgr->authen_connect or die; + my $row = $dbh->selectrow_hashref(qq{ + SELECT user, ip_ranges, scope FROM auth_tokens WHERE user = ? and token_id = ? and token_hash = ? and revoked = 0 and expires_at > NOW() + }, undef, $user, $token_id, Digest::SHA::hmac_sha256_hex($token, $token_id)); + die PAUSE::Web::Exception->new(ERROR => 'Invalid token') unless $row; + + $pause->{token_info} = $row; + + if (my $ip_ranges = $row->{ip_ranges}) { + require Net::CIDR; + my $ip = $c->tx->remote_address; + my @list = split /\n/, $ip_ranges; + die PAUSE::Web::Exception->new(ERROR => "Out of allowed IP ranges") unless Net::CIDR::cidrlookup($ip, @list); + } + + _retrieve_user($c, $row->{user}); +} + +# mostly taken from PAUSE::Web::Plugin::ConfigPerRequest +sub _retrieve_user { + my ($c, $user) = @_; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + + # This is a database application with nearly all users having write access + # Write access means expiration any moment + my $headers = $c->res->headers; + $headers->header('Pragma', 'no-cache'); + $headers->header('Cache-control', 'no-cache'); + # XXX: $res->no_cache(1); + # This is annoying when we ask for the who-is-who list and it + # hasn't changed since the last time, but for most cases it's + # safer to expire + + # we are not authenticating here, we retrieve the user record from + # the open database. Thus + my $dbh = $mgr->connect; # and not authentication database + local($dbh->{RaiseError}) = 0; + my($sql, $sth); + $sql = qq{SELECT * + FROM users + WHERE userid=? AND ustatus != 'nologin'}; + $sth = $dbh->prepare($sql); + if ($sth->execute($user)) { + if (0 == $sth->rows) { + my($sql7,$sth7); + $sql7 = qq{SELECT * + FROM users + WHERE userid=?}; + $sth7 = $dbh->prepare($sql7); + $sth7->execute($user); + my $error; + if ($sth7->rows > 0) { + $error = "User '$user' set to nologin. Your account may have been included in a precautionary password reset in the wake of a data breach + incident at some other site. Please talk to modules\@perl.org to find out how to proceed"; + } else { + $error = "User '$user' not known"; + } + die PAUSE::Web::Exception->new(ERROR => $error); + } else { + $pause->{User} = $mgr->fetchrow($sth, "fetchrow_hashref"); + } + } else { + die PAUSE::Web::Exception->new(ERROR => $dbh->errstr); + } + $sth->finish; + my $dbh2 = $mgr->authen_connect; + $sth = $dbh2->prepare("SELECT secretemail + FROM $PAUSE::Config->{AUTHEN_USER_TABLE} + WHERE $PAUSE::Config->{AUTHEN_USER_FLD}=?"); + $sth->execute($user); + my($secret_email) = $sth->fetchrow_array; + $pause->{User}{secretemail} = $secret_email; + $sth->finish; +} + 1; From e820d52b78893cdd5c1e946ab0ef0a8e6dccd5f1 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Fri, 24 Apr 2026 22:55:10 +0900 Subject: [PATCH 09/26] Add a controller that handles upload, based on PAUSE::Web::Controller::User::Uri::add --- lib/pause_2026/PAUSE/API/Controller/Upload.pm | 143 ++++++++++++++++++ 1 file changed, 143 insertions(+) create mode 100644 lib/pause_2026/PAUSE/API/Controller/Upload.pm diff --git a/lib/pause_2026/PAUSE/API/Controller/Upload.pm b/lib/pause_2026/PAUSE/API/Controller/Upload.pm new file mode 100644 index 00000000..0bd45788 --- /dev/null +++ b/lib/pause_2026/PAUSE/API/Controller/Upload.pm @@ -0,0 +1,143 @@ +package PAUSE::API::Controller::Upload; + +use Mojo::Base "Mojolicious::Controller"; +use Mojo::ByteStream; +use Mojo::URL; +use File::pushd; + +sub upload { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + my $token_info = $pause->{token_info} || {}; + my $scope = $token_info->{scope}; + + # TODO: finer control + die PAUSE::Web::Exception->new(ERROR => 'Invalid scope') unless $scope =~ /upload/; + + $PAUSE::Config->{INCOMING_LOC} =~ s|/$||; + + my $userid = uc $pause->{token_info}{user}; + my $userhome = PAUSE::user2dir($userid); + + my $upl = $req->upload('file'); + unless ($upl->size) { + return $c->render(json => {error => 'Empty file'}, status => 400); + } + + my $uri; + my $filename = $upl->filename; + $filename =~ s(.*/)()gs; # no slash + $filename =~ s(.*\\)()gs; # no backslash + $filename =~ s(.*:)()gs; # no colon + $filename =~ s/[^A-Za-z0-9_\-\.\@\+]//g; # only ASCII-\w and - . @ + allowed + my $to = "$PAUSE::Config->{INCOMING_LOC}/$filename"; + # my $fhi = $upl->fh; + if (-f $to && -s _ == 0) { # zero sized files are a common problem + unlink $to; + } + if ($upl->move_to($to)){ + $uri = $filename; + # Got an empty $to in the HTML page, so for debugging.. + $pause->{successfully_copied_to} = $to; + warn "h1[File successfully copied to '$to']filename[$filename]"; + } else { + die PAUSE::Web::Exception->new(ERROR => "Couldn't copy file '$filename' to '$to': $!"); + } + unless ($upl->filename eq $filename) { + require Dumpvalue; + my $dv = Dumpvalue->new; + $pause->{upload_is_renamed} = { + from => $dv->stringify($upl->filename), + to => $dv->stringify($filename), + }; + } + my $dbh = $mgr->connect; + my $now = time; + my $server = $PAUSE::Config->{SERVER_NAME} || $req->url->to_abs->host; + + eval { Mojo::URL->new("$PAUSE::Config->{INCOMING}/$uri") }; + if ($@) { + $pause->{invalid_uri} = 1; + # FIXME + die PAUSE::Web::Exception + ->new(ERROR => [Mojo::ByteStream->new(qq{ +Sorry, $uri could not be recognized as an uri (}), + $@, + Mojo::ByteStream->new(qq{\)Please +try again or report errors to the administrator

})]); + } else { + require LWP::UserAgent; + my $ua = LWP::UserAgent->new; + $ua->timeout($PAUSE::Config->{TIMEOUT}) if $PAUSE::Config->{TIMEOUT}; + my $res = $ua->head($uri); + my $filename = $res && $res->is_success ? $res->filename : undef; + $filename ||= $uri; # as a last resort + $filename =~ s,.*/,, ; + $filename =~ s/[^A-Za-z0-9_\-\.\@\+]//g; # only ASCII-\w and - . @ + allowed + + if ($filename eq "CHECKSUMS") { + # userid DERHAAG demonstrated that it could be uploaded on 2002-04-26 + die PAUSE::Web::Exception + ->new(ERROR => "Files with the name CHECKSUMS cannot be + uploaded to CPAN, they are reserved for + CPAN's internals."); + + } + my $subdir = ""; + if ( $req->param("subdir") ) { + $subdir = $req->param("subdir"); + } + + my $uriid = "$userhome/$filename"; + + if (defined $subdir && length $subdir) { + # disallowing . to make /./ and /../ handling easier + $subdir =~ s|[^A-Za-z0-9_\-\@\+/]||g; # as above minus "." plus "/" + $subdir =~ s|^/+||; + $subdir =~ s|/$||; + $subdir =~ s|/+|/|g; + } + my $is_perl6 = 0; + if (defined $subdir && length $subdir) { + $is_perl6 = 1 if $subdir =~ /^Perl6\b/; + $uriid = "$userhome/$subdir/$filename"; + } + + if ( length $uriid > 255 ) { + die PAUSE::Web::Exception + ->new(ERROR => "Path name too long: $uriid is longer than 255 characters."); + } + + ALLOW_OVERWRITE: if (PAUSE::may_overwrite_file($filename)) { + $dbh->do("DELETE FROM uris WHERE uriid = ?", undef, $uriid); + } + + my $query = q{INSERT INTO uris + (uriid, userid, + basename, + uri, + changedby, changed, is_perl6) + VALUES (?, ?, ?, ?, ?, ?, ?)}; + my @query_params = ( + $uriid, $userid, $filename, $uri, $pause->{User}{userid}, $now, + $is_perl6 + ); + #display query + local($dbh->{RaiseError}) = 0; + if ($dbh->do($query, undef, @query_params)) { + return $c->render(json => {result => 'Upload succeeded'}, status => 200); + } else { + my $errmsg = $dbh->errstr; + if ($errmsg =~ /non\s+unique\s+key|Duplicate/i) { + return $c->render(json => {error => 'Duplicated'}, status => 409); + } + return $c->render(json => {error => 'Not accepted'}, status => 406); + } + } +} + +1; From bb0cce2e48459617c5632f47f5fdc64bd69b12ae Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Fri, 24 Apr 2026 22:55:50 +0900 Subject: [PATCH 10/26] Add a new .psgi app --- app_2026.psgi | 90 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 90 insertions(+) create mode 100644 app_2026.psgi diff --git a/app_2026.psgi b/app_2026.psgi new file mode 100644 index 00000000..cd74e81c --- /dev/null +++ b/app_2026.psgi @@ -0,0 +1,90 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use FindBin; +use lib "$FindBin::Bin/lib/", "$FindBin::Bin/lib/pause_2026", "$FindBin::Bin/lib/pause_2017", "$FindBin::Bin/../pause-private/lib", "$FindBin::Bin/privatelib"; +use Plack::Builder; +use Plack::App::Directory::Apaxy; +use Path::Tiny; +my $AppRoot = path(__FILE__)->parent->realpath; +Log::Dispatch::Config->configure("$AppRoot/etc/plack_log.conf.".($ENV{PLACK_ENV} // 'development')); + +$ENV{MOJO_REVERSE_PROXY} = 1; +$ENV{MOJO_HOME} = $AppRoot; + +# preload stuff +use PAUSE::Web2026::Context; +use PAUSE::Web; +use PAUSE::API::Context; +use PAUSE::API; +use PAUSE::Web::App::Index; +use PAUSE::Web::App::Disabled; + +use BSD::Resource (); +#BSD::Resource::setrlimit(BSD::Resource::RLIMIT_CPU(), +# 60*10, 60*10); +#BSD::Resource::setrlimit(BSD::Resource::RLIMIT_DATA(), +# 40*1024*1024, 40*1024*1024); +BSD::Resource::setrlimit(BSD::Resource::RLIMIT_CORE(), + 40*1024*1024, 40*1024*1024); + +my $builder = eval { + +my $context = PAUSE::Web2026::Context->new(root => $AppRoot); +$context->init; + +my $api_context = PAUSE::API::Context->new(root => $AppRoot); +$api_context->init; + +my $pause_app = PAUSE::Web->new(pause => $context); +my $api_app = PAUSE::API->new(pause => $api_context); +my $index_app = PAUSE::Web::App::Index->new->to_app; +my $disabled_app = PAUSE::Web::App::Disabled->new->to_app; + +builder { + enable 'LogDispatch', logger => $context->logger; + enable 'ReverseProxy'; + enable 'ServerStatus::Tiny', path => '/status'; + + if (-f "/etc/PAUSE.CLOSED") { + mount '/' => builder { $disabled_app }; + } else { + # Static files are serverd by us; maybe some day we want to change that + enable 'Static', + path => qr{(?:(? "$FindBin::Bin/htdocs"; + + mount '/pub/PAUSE' => builder { + enable '+PAUSE::Web::Middleware::Auth::Basic', context => $context; + Plack::App::Directory::Apaxy->new(root => $PAUSE::Config->{FTPPUB}); + }; + + mount '/incoming' => builder { + enable '+PAUSE::Web::Middleware::Auth::Basic', context => $context; + Plack::App::Directory::Apaxy->new(root => $PAUSE::Config->{INCOMING_LOC}); + }; + + mount '/api' => builder { + $api_app->start('psgi'); + }; + + mount '/pause' => builder { + enable_if {$_[0]->{PATH_INFO} =~ /authenquery/ ? 1 : 0} '+PAUSE::Web::Middleware::Auth::Basic', context => $context; + $pause_app->start('psgi'); + }; + + mount '/' => builder { $index_app }; + } +}; + +}; + +if ($@) { + Log::Dispatch::Config->instance->log( + level => 'error', + message => "$@", + ); +} + +$builder; From e6f7f7972bbab5b1502ae606a4229ef2da2d1dda Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Fri, 24 Apr 2026 22:56:11 +0900 Subject: [PATCH 11/26] Add a one-off util to change schema --- one-off-utils/schemachange-2026-04.sql | 14 ++++++++++++++ 1 file changed, 14 insertions(+) create mode 100644 one-off-utils/schemachange-2026-04.sql diff --git a/one-off-utils/schemachange-2026-04.sql b/one-off-utils/schemachange-2026-04.sql new file mode 100644 index 00000000..d4d5312b --- /dev/null +++ b/one-off-utils/schemachange-2026-04.sql @@ -0,0 +1,14 @@ +CREATE TABLE auth_tokens ( + id INTEGER AUTO_INCREMENT PRIMARY KEY, + user VARCHAR(9), + token_id VARCHAR(8), + token_hash VARCHAR(64), + description VARCHAR(255), + expires_at DATETIME NOT NULL, + ip_ranges TEXT, + scope TEXT, + revoked TINYINT DEFAULT 0, + created_at DATETIME DEFAULT CURRENT_TIMESTAMP, + INDEX(user, token_id, token_hash), + INDEX(user, revoked) +); From 0b08da2d7b473941fceed48803b7ca98ba1257c7 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Fri, 24 Apr 2026 22:56:57 +0900 Subject: [PATCH 12/26] Add a test --- t/pause_2026/00_load.t | 20 ++++++++++++++++++++ t/pause_2026/lib/Test/PAUSE/Web2026.pm | 16 ++++++++++++++++ 2 files changed, 36 insertions(+) create mode 100644 t/pause_2026/00_load.t create mode 100644 t/pause_2026/lib/Test/PAUSE/Web2026.pm diff --git a/t/pause_2026/00_load.t b/t/pause_2026/00_load.t new file mode 100644 index 00000000..2b7d952e --- /dev/null +++ b/t/pause_2026/00_load.t @@ -0,0 +1,20 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/lib", "$FindBin::Bin/../pause_2017/lib"; +use Test::PAUSE::Web2026; +use Test::More; +use File::Find; +use Path::Tiny; + +note "AppRoot: $Test::PAUSE::Web::AppRoot"; + +find({wanted => sub { + my $file = path($File::Find::name); + my $path = $file->relative("$Test::PAUSE::Web::AppRoot/lib/pause_2026"); + $path =~ s|\.pm$|| or return; + $path =~ s|/|::|g; + use_ok($path); +}, no_chdir => 1}, "$Test::PAUSE::Web::AppRoot/lib/pause_2026/PAUSE"); + +done_testing; + diff --git a/t/pause_2026/lib/Test/PAUSE/Web2026.pm b/t/pause_2026/lib/Test/PAUSE/Web2026.pm new file mode 100644 index 00000000..13757e32 --- /dev/null +++ b/t/pause_2026/lib/Test/PAUSE/Web2026.pm @@ -0,0 +1,16 @@ +package Test::PAUSE::Web2026; + +use strict; +use warnings; +use Test::PAUSE::Web; +use parent 'Test::PAUSE::Web'; +use Exporter qw/import/; + +our @EXPORT = @Test::PAUSE::Web::EXPORT; + +unshift @INC, "$Test::PAUSE::Web::AppRoot/lib/pause_2026"; + +$ENV{TEST_PAUSE_WEB_PSGI} //= "app_2026.psgi"; + +1; + From 33ff85d90033edde429c4ff9e14c97b70af1d43b Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 25 Apr 2026 16:22:07 +0900 Subject: [PATCH 13/26] Add Crypt::PRNG to cpanfile --- cpanfile | 1 + 1 file changed, 1 insertion(+) diff --git a/cpanfile b/cpanfile index 1580c356..2da38450 100644 --- a/cpanfile +++ b/cpanfile @@ -5,6 +5,7 @@ requires 'CPAN::DistnameInfo'; requires 'CPAN::Indexer::Mirror'; requires 'Class::Singleton'; requires 'Crypt::Eksblowfish::Bcrypt'; +requires 'Crypt::PRNG'; requires 'Crypt::URandom'; requires 'DB_File'; requires 'DBI'; From 481a6d895f23270a5b56bd1f1108d17363d17d27 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sun, 26 Apr 2026 18:29:43 +0900 Subject: [PATCH 14/26] Remove a useless line --- lib/pause_2026/templates/user/tokens/generate.html.ep | 1 - 1 file changed, 1 deletion(-) diff --git a/lib/pause_2026/templates/user/tokens/generate.html.ep b/lib/pause_2026/templates/user/tokens/generate.html.ep index 1fec0247..e1955ac9 100644 --- a/lib/pause_2026/templates/user/tokens/generate.html.ep +++ b/lib/pause_2026/templates/user/tokens/generate.html.ep @@ -1,6 +1,5 @@ % layout 'layout'; % my $pause = stash(".pause") || {}; -% my $cpan_alias = lc($pause->{HiddenUser}{userid}) . '@cpan.org'; From b578e1198ce9757b1c82af3f797ab0108f16bf66 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sun, 26 Apr 2026 18:32:44 +0900 Subject: [PATCH 15/26] Just use Crypt::URandom --- cpanfile | 1 - lib/pause_2026/PAUSE/Web2026/Controller/User/Tokens.pm | 6 +++--- 2 files changed, 3 insertions(+), 4 deletions(-) diff --git a/cpanfile b/cpanfile index 2da38450..1580c356 100644 --- a/cpanfile +++ b/cpanfile @@ -5,7 +5,6 @@ requires 'CPAN::DistnameInfo'; requires 'CPAN::Indexer::Mirror'; requires 'Class::Singleton'; requires 'Crypt::Eksblowfish::Bcrypt'; -requires 'Crypt::PRNG'; requires 'Crypt::URandom'; requires 'DB_File'; requires 'DBI'; diff --git a/lib/pause_2026/PAUSE/Web2026/Controller/User/Tokens.pm b/lib/pause_2026/PAUSE/Web2026/Controller/User/Tokens.pm index 658cb259..300f5066 100644 --- a/lib/pause_2026/PAUSE/Web2026/Controller/User/Tokens.pm +++ b/lib/pause_2026/PAUSE/Web2026/Controller/User/Tokens.pm @@ -4,7 +4,7 @@ use Mojo::Base "Mojolicious::Controller"; use HTTP::Date (); use File::pushd; use PAUSE (); -use Crypt::PRNG; +use Crypt::URandom; use Digest::SHA; sub list { @@ -57,8 +57,8 @@ sub generate { my $u = $c->active_user_record; if ($req->param('new_token_sub')) { - my $token = Crypt::PRNG::random_bytes_hex(32); - my $token_id = Crypt::PRNG::random_bytes_hex(4); + my $token = unpack 'H*', Crypt::URandom::urandom(32); + my $token_id = unpack 'H*', Crypt::URandom::urandom(4); my $token_hash = Digest::SHA::hmac_sha256_hex($token, $token_id); my $description = $req->param('new_token_description'); my $expires_in = $req->param('new_token_expires_in') || 180; From b4924849459b6fa9edb12bebd59a8470da4ccff8 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sun, 26 Apr 2026 19:31:57 +0900 Subject: [PATCH 16/26] Fix wrong hmac usage --- lib/pause_2026/PAUSE/API/Controller/Root.pm | 2 +- lib/pause_2026/PAUSE/Web2026/Controller/User/Tokens.pm | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/pause_2026/PAUSE/API/Controller/Root.pm b/lib/pause_2026/PAUSE/API/Controller/Root.pm index 603fb52f..49700518 100644 --- a/lib/pause_2026/PAUSE/API/Controller/Root.pm +++ b/lib/pause_2026/PAUSE/API/Controller/Root.pm @@ -55,7 +55,7 @@ sub check_token { my $dbh = $mgr->authen_connect or die; my $row = $dbh->selectrow_hashref(qq{ SELECT user, ip_ranges, scope FROM auth_tokens WHERE user = ? and token_id = ? and token_hash = ? and revoked = 0 and expires_at > NOW() - }, undef, $user, $token_id, Digest::SHA::hmac_sha256_hex($token, $token_id)); + }, undef, $user, $token_id, Digest::SHA::hmac_sha256_hex($token_id, $token)); die PAUSE::Web::Exception->new(ERROR => 'Invalid token') unless $row; $pause->{token_info} = $row; diff --git a/lib/pause_2026/PAUSE/Web2026/Controller/User/Tokens.pm b/lib/pause_2026/PAUSE/Web2026/Controller/User/Tokens.pm index 300f5066..67c6dfb0 100644 --- a/lib/pause_2026/PAUSE/Web2026/Controller/User/Tokens.pm +++ b/lib/pause_2026/PAUSE/Web2026/Controller/User/Tokens.pm @@ -59,7 +59,7 @@ sub generate { if ($req->param('new_token_sub')) { my $token = unpack 'H*', Crypt::URandom::urandom(32); my $token_id = unpack 'H*', Crypt::URandom::urandom(4); - my $token_hash = Digest::SHA::hmac_sha256_hex($token, $token_id); + my $token_hash = Digest::SHA::hmac_sha256_hex($token_id, $token); my $description = $req->param('new_token_description'); my $expires_in = $req->param('new_token_expires_in') || 180; my $ip_ranges = $req->param('new_token_ip_ranges'); From 2a04dec747b841e2b48a0b067222cf16ba4f47ad Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sun, 26 Apr 2026 20:16:15 +0900 Subject: [PATCH 17/26] Remove Authorization header after it is retrieved --- lib/pause_2026/PAUSE/API/Controller/Root.pm | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/pause_2026/PAUSE/API/Controller/Root.pm b/lib/pause_2026/PAUSE/API/Controller/Root.pm index 49700518..7ba4bdf0 100644 --- a/lib/pause_2026/PAUSE/API/Controller/Root.pm +++ b/lib/pause_2026/PAUSE/API/Controller/Root.pm @@ -41,6 +41,7 @@ sub check_token { my $c = shift; my $header = $c->req->headers->header('Authorization'); die PAUSE::Web::Exception->new(ERROR => 'No authorization header') unless $header; + $c->req->headers->remove('Authorization'); # to prevent reuse $header =~ s/Bearer\s+//i or die PAUSE::Web::Exception->new(ERROR => 'No Bearer token'); my ($user, $token_id, $token) = split ':', $header; From 7cad62ab14c04a0c8177ef87a1994a690bcb55a3 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sun, 26 Apr 2026 20:16:43 +0900 Subject: [PATCH 18/26] Tighten the scope check --- lib/pause_2026/PAUSE/API/Controller/Upload.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/pause_2026/PAUSE/API/Controller/Upload.pm b/lib/pause_2026/PAUSE/API/Controller/Upload.pm index 0bd45788..afb342da 100644 --- a/lib/pause_2026/PAUSE/API/Controller/Upload.pm +++ b/lib/pause_2026/PAUSE/API/Controller/Upload.pm @@ -14,7 +14,7 @@ sub upload { my $scope = $token_info->{scope}; # TODO: finer control - die PAUSE::Web::Exception->new(ERROR => 'Invalid scope') unless $scope =~ /upload/; + die PAUSE::Web::Exception->new(ERROR => 'Invalid scope') unless $scope eq 'upload'; $PAUSE::Config->{INCOMING_LOC} =~ s|/$||; From de0d2f937cb8328f6f3a6226cbc3dad01854b6fe Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sun, 26 Apr 2026 20:17:32 +0900 Subject: [PATCH 19/26] Use longer token_id, mark some columns not null, and add a unique index --- lib/pause_2026/PAUSE/Web2026/Controller/User/Tokens.pm | 2 +- one-off-utils/schemachange-2026-04.sql | 7 ++++--- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/lib/pause_2026/PAUSE/Web2026/Controller/User/Tokens.pm b/lib/pause_2026/PAUSE/Web2026/Controller/User/Tokens.pm index 67c6dfb0..d96ba38a 100644 --- a/lib/pause_2026/PAUSE/Web2026/Controller/User/Tokens.pm +++ b/lib/pause_2026/PAUSE/Web2026/Controller/User/Tokens.pm @@ -58,7 +58,7 @@ sub generate { if ($req->param('new_token_sub')) { my $token = unpack 'H*', Crypt::URandom::urandom(32); - my $token_id = unpack 'H*', Crypt::URandom::urandom(4); + my $token_id = unpack 'H*', Crypt::URandom::urandom(16); my $token_hash = Digest::SHA::hmac_sha256_hex($token_id, $token); my $description = $req->param('new_token_description'); my $expires_in = $req->param('new_token_expires_in') || 180; diff --git a/one-off-utils/schemachange-2026-04.sql b/one-off-utils/schemachange-2026-04.sql index d4d5312b..637c2cd7 100644 --- a/one-off-utils/schemachange-2026-04.sql +++ b/one-off-utils/schemachange-2026-04.sql @@ -1,14 +1,15 @@ CREATE TABLE auth_tokens ( id INTEGER AUTO_INCREMENT PRIMARY KEY, - user VARCHAR(9), - token_id VARCHAR(8), - token_hash VARCHAR(64), + user VARCHAR(9) NOT NULL, + token_id VARCHAR(32) NOT NULL, + token_hash VARCHAR(64) NOT NULL, description VARCHAR(255), expires_at DATETIME NOT NULL, ip_ranges TEXT, scope TEXT, revoked TINYINT DEFAULT 0, created_at DATETIME DEFAULT CURRENT_TIMESTAMP, + UNIQUE(user, token_id), INDEX(user, token_id, token_hash), INDEX(user, revoked) ); From 5953eef39bf30f5a8b30230404ce912db6db6c34 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sun, 26 Apr 2026 21:39:15 +0900 Subject: [PATCH 20/26] Fix a log level --- lib/pause_2026/PAUSE/API.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/pause_2026/PAUSE/API.pm b/lib/pause_2026/PAUSE/API.pm index 5075e6ce..713d70f2 100644 --- a/lib/pause_2026/PAUSE/API.pm +++ b/lib/pause_2026/PAUSE/API.pm @@ -68,7 +68,7 @@ sub _wrap { require Data::Dumper; my $message = "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([$pause->{ERROR}],[qw(error)])->Indent(1)->Useqq(1)-> Dump; - $c->app->pause->log({level => 'debug', message => $message}); + $c->app->pause->log({level => 'error', message => $message}); $c->res->code($e->{HTTP_STATUS} // HTTP_BAD_REQUEST); return $c->render(json => { error => $pause->{ERROR} }) } elsif ($e->{HTTP_STATUS}) { From f83c68cb4d5fa1ced571fd19bca24d10959ce0fe Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sun, 26 Apr 2026 21:40:29 +0900 Subject: [PATCH 21/26] Initialize .pause stash earlier --- lib/pause_2026/PAUSE/API/Controller/Root.pm | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/lib/pause_2026/PAUSE/API/Controller/Root.pm b/lib/pause_2026/PAUSE/API/Controller/Root.pm index 7ba4bdf0..8c6704df 100644 --- a/lib/pause_2026/PAUSE/API/Controller/Root.pm +++ b/lib/pause_2026/PAUSE/API/Controller/Root.pm @@ -39,6 +39,11 @@ sub _pause_is_closed { sub check_token { my $c = shift; + my $pause = $c->stash('.pause'); + if (!$pause) { + $c->stash(".pause" => $pause = {}); + } + my $header = $c->req->headers->header('Authorization'); die PAUSE::Web::Exception->new(ERROR => 'No authorization header') unless $header; $c->req->headers->remove('Authorization'); # to prevent reuse @@ -47,10 +52,6 @@ sub check_token { my ($user, $token_id, $token) = split ':', $header; die PAUSE::Web::Exception->new(ERROR => 'Invalid token') if !$user or !$token_id or !$token; - my $pause = $c->stash('.pause'); - if (!$pause) { - $c->stash(".pause" => $pause = {}); - } my $mgr = $c->app->pause; my $dbh = $mgr->authen_connect or die; From 753988f7322d9c4e917a7fcaf9cb5d3c52d5230d Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sun, 26 Apr 2026 21:42:30 +0900 Subject: [PATCH 22/26] Store bearer information in .pause to log later --- lib/pause_2026/PAUSE/API/Controller/Root.pm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/pause_2026/PAUSE/API/Controller/Root.pm b/lib/pause_2026/PAUSE/API/Controller/Root.pm index 8c6704df..f6887da8 100644 --- a/lib/pause_2026/PAUSE/API/Controller/Root.pm +++ b/lib/pause_2026/PAUSE/API/Controller/Root.pm @@ -50,8 +50,9 @@ sub check_token { $header =~ s/Bearer\s+//i or die PAUSE::Web::Exception->new(ERROR => 'No Bearer token'); my ($user, $token_id, $token) = split ':', $header; - die PAUSE::Web::Exception->new(ERROR => 'Invalid token') if !$user or !$token_id or !$token; + $pause->{bearer} = {user => $user, token_id => $token_id}; + die PAUSE::Web::Exception->new(ERROR => 'Invalid token') if !$user or !$token_id or !$token; my $mgr = $c->app->pause; my $dbh = $mgr->authen_connect or die; From 01232e33452b92884687e3e0950140fdade21469 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sun, 26 Apr 2026 21:44:27 +0900 Subject: [PATCH 23/26] Introduce auth_log --- lib/pause_2026/PAUSE/API.pm | 20 +++++++++++++++----- lib/pause_2026/PAUSE/API/Controller/Root.pm | 13 +++++++++++++ one-off-utils/schemachange-2026-04.sql | 11 +++++++++++ 3 files changed, 39 insertions(+), 5 deletions(-) diff --git a/lib/pause_2026/PAUSE/API.pm b/lib/pause_2026/PAUSE/API.pm index 713d70f2..f07bdff2 100644 --- a/lib/pause_2026/PAUSE/API.pm +++ b/lib/pause_2026/PAUSE/API.pm @@ -61,6 +61,7 @@ sub _wrap { my $res = eval { $next->(); }; if (my $e = $@) { + my $error; if (UNIVERSAL::isa($e, "PAUSE::Web::Exception")) { if ($e->{ERROR}) { $e->{ERROR} = [ $e->{ERROR} ] unless ref $e->{ERROR} eq 'ARRAY'; @@ -70,17 +71,26 @@ sub _wrap { Dump; $c->app->pause->log({level => 'error', message => $message}); $c->res->code($e->{HTTP_STATUS} // HTTP_BAD_REQUEST); - return $c->render(json => { error => $pause->{ERROR} }) + + $error = $pause->{ERROR}; } elsif ($e->{HTTP_STATUS}) { - return $c->render(json => {error => status_message($e->{HTTP_STATUS})}); + $error = status_message($e->{HTTP_STATUS}); } } else { # this is NOT a known error type, we need to handle it anon - my $error = "$e"; - $c->app->pause->log({level => 'error', message => $error }); + $c->app->pause->log({level => 'error', message => "$e" }); $c->res->code(HTTP_INTERNAL_SERVER_ERROR); - return $c->render(json => {error => 'Internal server error'}); + $error = 'Internal server error'; } + + my $bearer = $pause->{bearer}; + my $dbh = $c->app->pause->authen_connect; + $dbh->do(qq{ + INSERT INTO auth_log (user, token_id, ip, error) + VALUES (?, ?, ?, ?)}, undef, + $bearer->{user}, $bearer->{token_id}, $c->tx->remote_address, ref $error ? encode_json($error) : $error + ); + return $c->render(json => {error => $error}); } return $res; } diff --git a/lib/pause_2026/PAUSE/API/Controller/Root.pm b/lib/pause_2026/PAUSE/API/Controller/Root.pm index f6887da8..1a097944 100644 --- a/lib/pause_2026/PAUSE/API/Controller/Root.pm +++ b/lib/pause_2026/PAUSE/API/Controller/Root.pm @@ -129,6 +129,19 @@ sub _retrieve_user { my($secret_email) = $sth->fetchrow_array; $pause->{User}{secretemail} = $secret_email; $sth->finish; + + my $ip = $c->tx->remote_address; + + my $bearer = $pause->{bearer}; + my $dbh = $c->app->pause->authen_connect; + $dbh->do(qq{ + INSERT INTO auth_log (user, token_id, ip) + VALUES (?, ?, ?, ?)}, undef, + $bearer->{user}, $bearer->{token_id}, $ip + ); + $mgr->log({level => 'info', message => "Token authentication for '$user' succeeded, using '$bearer->{token_id}' [$ip]"}); + + return 1; } 1; diff --git a/one-off-utils/schemachange-2026-04.sql b/one-off-utils/schemachange-2026-04.sql index 637c2cd7..3ddba1ac 100644 --- a/one-off-utils/schemachange-2026-04.sql +++ b/one-off-utils/schemachange-2026-04.sql @@ -13,3 +13,14 @@ CREATE TABLE auth_tokens ( INDEX(user, token_id, token_hash), INDEX(user, revoked) ); + +CREATE TABLE auth_log ( + id INTEGER AUTO_INCREMENT PRIMARY KEY, + user VARCHAR(9) NOT NULL, + token_id VARCHAR(32) DEFAULT '', + ip VARCHAR(16) NOT NULL, + error TEXT, + created_at DATETIME DEFAULT CURRENT_TIMESTAMP, + INDEX(user, token_id), + INDEX(user, ip) +); From bde146ff299a94d0b337eae811842585da3a0fd0 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sun, 26 Apr 2026 21:45:09 +0900 Subject: [PATCH 24/26] Fix scope mismatch --- lib/pause_2026/PAUSE/API/Controller/Upload.pm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/pause_2026/PAUSE/API/Controller/Upload.pm b/lib/pause_2026/PAUSE/API/Controller/Upload.pm index afb342da..a6216a3e 100644 --- a/lib/pause_2026/PAUSE/API/Controller/Upload.pm +++ b/lib/pause_2026/PAUSE/API/Controller/Upload.pm @@ -14,7 +14,7 @@ sub upload { my $scope = $token_info->{scope}; # TODO: finer control - die PAUSE::Web::Exception->new(ERROR => 'Invalid scope') unless $scope eq 'upload'; + die PAUSE::Web::Exception->new(ERROR => 'Invalid scope') unless $scope eq 'upload:distributions'; $PAUSE::Config->{INCOMING_LOC} =~ s|/$||; From 1b3983dd2611e931b67af4aceb50c1169389980d Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sun, 26 Apr 2026 21:45:36 +0900 Subject: [PATCH 25/26] Add a TODO comment --- lib/pause_2026/PAUSE/API/Controller/Root.pm | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/lib/pause_2026/PAUSE/API/Controller/Root.pm b/lib/pause_2026/PAUSE/API/Controller/Root.pm index 1a097944..b7519240 100644 --- a/lib/pause_2026/PAUSE/API/Controller/Root.pm +++ b/lib/pause_2026/PAUSE/API/Controller/Root.pm @@ -56,6 +56,11 @@ sub check_token { my $mgr = $c->app->pause; my $dbh = $mgr->authen_connect or die; + + # TODO: We should add a rate-limit check, and send an email to the admins if necessary so that they can + # add some measures in front of the API app (fail2ban, etc), or unban a user by a DB query, + # or via a new web user interface that lists the relevant auth log etc. + my $row = $dbh->selectrow_hashref(qq{ SELECT user, ip_ranges, scope FROM auth_tokens WHERE user = ? and token_id = ? and token_hash = ? and revoked = 0 and expires_at > NOW() }, undef, $user, $token_id, Digest::SHA::hmac_sha256_hex($token_id, $token)); From 3d9622a257307c26accd3aa17e9c477cbba3f77e Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sun, 26 Apr 2026 22:17:35 +0900 Subject: [PATCH 26/26] Oops --- lib/pause_2026/PAUSE/API/Controller/Root.pm | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/lib/pause_2026/PAUSE/API/Controller/Root.pm b/lib/pause_2026/PAUSE/API/Controller/Root.pm index b7519240..db6f120c 100644 --- a/lib/pause_2026/PAUSE/API/Controller/Root.pm +++ b/lib/pause_2026/PAUSE/API/Controller/Root.pm @@ -138,10 +138,9 @@ sub _retrieve_user { my $ip = $c->tx->remote_address; my $bearer = $pause->{bearer}; - my $dbh = $c->app->pause->authen_connect; - $dbh->do(qq{ + $dbh2->do(qq{ INSERT INTO auth_log (user, token_id, ip) - VALUES (?, ?, ?, ?)}, undef, + VALUES (?, ?, ?)}, undef, $bearer->{user}, $bearer->{token_id}, $ip ); $mgr->log({level => 'info', message => "Token authentication for '$user' succeeded, using '$bearer->{token_id}' [$ip]"});