New API app to handle upload with a bearer token

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{(?:(?<!index)\.(js|css|gif|jpg|png|pod|html)$|^/\.well-known/)},
+        root => "$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;

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;

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;
+
+

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;