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;
diff --git a/lib/pause_2026/PAUSE/API.pm b/lib/pause_2026/PAUSE/API.pm
new file mode 100644
index 00000000..f07bdff2
--- /dev/null
+++ b/lib/pause_2026/PAUSE/API.pm
@@ -0,0 +1,98 @@
+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 = $@) {
+ my $error;
+ 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 => 'error', message => $message});
+ $c->res->code($e->{HTTP_STATUS} // HTTP_BAD_REQUEST);
+
+ $error = $pause->{ERROR};
+ } elsif ($e->{HTTP_STATUS}) {
+ $error = status_message($e->{HTTP_STATUS});
+ }
+ } else {
+ # this is NOT a known error type, we need to handle it anon
+ $c->app->pause->log({level => 'error', message => "$e" });
+ $c->res->code(HTTP_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;
+}
+
+1;
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;
+
+
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..db6f120c
--- /dev/null
+++ b/lib/pause_2026/PAUSE/API/Controller/Root.pm
@@ -0,0 +1,151 @@
+package PAUSE::API::Controller::Root;
+
+use Mojo::Base "Mojolicious::Controller";
+use HTTP::Date ();
+use Time::Duration ();
+use PAUSE;
+use Digest::SHA;
+
+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;
+}
+
+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
+ $header =~ s/Bearer\s+//i or die PAUSE::Web::Exception->new(ERROR => 'No Bearer token');
+
+ my ($user, $token_id, $token) = split ':', $header;
+ $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;
+
+ # 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));
+ 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;
+
+ my $ip = $c->tx->remote_address;
+
+ my $bearer = $pause->{bearer};
+ $dbh2->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/lib/pause_2026/PAUSE/API/Controller/Upload.pm b/lib/pause_2026/PAUSE/API/Controller/Upload.pm
new file mode 100644
index 00000000..a6216a3e
--- /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 eq 'upload:distributions';
+
+ $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;
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;
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;
+
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..d96ba38a
--- /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::URandom;
+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 = unpack 'H*', Crypt::URandom::urandom(32);
+ 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;
+ 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;
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..e1955ac9
--- /dev/null
+++ b/lib/pause_2026/templates/user/tokens/generate.html.ep
@@ -0,0 +1,61 @@
+% layout 'layout';
+% my $pause = stash(".pause") || {};
+
+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
+Tokens for <%= $pause->{HiddenUser}{userid} %>
+
+% if (@$tokens) {
+
+%= 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} %>
+% }
diff --git a/one-off-utils/schemachange-2026-04.sql b/one-off-utils/schemachange-2026-04.sql
new file mode 100644
index 00000000..3ddba1ac
--- /dev/null
+++ b/one-off-utils/schemachange-2026-04.sql
@@ -0,0 +1,26 @@
+CREATE TABLE auth_tokens (
+ id INTEGER AUTO_INCREMENT PRIMARY KEY,
+ 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)
+);
+
+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)
+);
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;
+