From 2ada6b09311374080ee1fc0d4c5025a8add978e6 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 19 Apr 2025 17:00:10 +0900 Subject: [PATCH 01/51] Copy lib/pause_2017 files into lib/pause_2025 --- lib/pause_2025/PAUSE/Web.pm | 103 +++ lib/pause_2025/PAUSE/Web/App/Disabled.pm | 31 + lib/pause_2025/PAUSE/Web/App/Index.pm | 61 ++ lib/pause_2025/PAUSE/Web/Config.pm | 656 +++++++++++++++++ lib/pause_2025/PAUSE/Web/Context.pm | 213 ++++++ lib/pause_2025/PAUSE/Web/Controller/Admin.pm | 202 ++++++ .../PAUSE/Web/Controller/Admin/ManageId.pm | 66 ++ .../PAUSE/Web/Controller/Admin/User.pm | 307 ++++++++ lib/pause_2025/PAUSE/Web/Controller/Mlrepr.pm | 78 +++ lib/pause_2025/PAUSE/Web/Controller/Public.pm | 223 ++++++ .../PAUSE/Web/Controller/Public/RequestId.pm | 269 +++++++ lib/pause_2025/PAUSE/Web/Controller/Root.pm | 50 ++ lib/pause_2025/PAUSE/Web/Controller/User.pm | 420 +++++++++++ .../PAUSE/Web/Controller/User/Cred.pm | 221 ++++++ .../PAUSE/Web/Controller/User/Distperms.pm | 554 +++++++++++++++ .../PAUSE/Web/Controller/User/Files.pm | 218 ++++++ .../PAUSE/Web/Controller/User/Perms.pm | 659 ++++++++++++++++++ .../PAUSE/Web/Controller/User/Uri.pm | 280 ++++++++ lib/pause_2025/PAUSE/Web/Exception.pm | 9 + .../PAUSE/Web/Middleware/Auth/Basic.pm | 190 +++++ .../PAUSE/Web/Plugin/ConfigPerRequest.pm | 327 +++++++++ lib/pause_2025/PAUSE/Web/Plugin/Delegate.pm | 23 + lib/pause_2025/PAUSE/Web/Plugin/EditUtils.pm | 37 + lib/pause_2025/PAUSE/Web/Plugin/FixAction.pm | 70 ++ .../PAUSE/Web/Plugin/GetActiveUserRecord.pm | 181 +++++ .../PAUSE/Web/Plugin/GetUserMeta.pm | 184 +++++ .../PAUSE/Web/Plugin/IsPauseClosed.pm | 41 ++ lib/pause_2025/PAUSE/Web/Plugin/MyURL.pm | 29 + lib/pause_2025/PAUSE/Web/Plugin/RenderYAML.pm | 21 + .../PAUSE/Web/Plugin/ServePauseDoc.pm | 53 ++ .../PAUSE/Web/Plugin/SessionCounted.pm | 92 +++ lib/pause_2025/PAUSE/Web/Plugin/TextFormat.pm | 18 + .../PAUSE/Web/Plugin/UserRegistration.pm | 136 ++++ lib/pause_2025/PAUSE/Web/Plugin/WrapAction.pm | 54 ++ lib/pause_2025/PAUSE/Web/Util/Encode.pm | 69 ++ lib/pause_2025/PAUSE/Web/Util/RewriteXHTML.pm | 82 +++ lib/pause_2025/TODO | 27 + lib/pause_2025/templates/_closed.html.ep | 3 + lib/pause_2025/templates/_debug.html.ep | 285 ++++++++ lib/pause_2025/templates/_user_menu.html.ep | 46 ++ lib/pause_2025/templates/_user_status.html.ep | 22 + .../templates/admin/edit_ml.html.ep | 74 ++ .../templates/admin/email_for_admin.html.ep | 35 + .../templates/admin/manage_id/manage.html.ep | 54 ++ .../templates/admin/select_user.html.ep | 16 + .../templates/admin/user/add.html.ep | 202 ++++++ lib/pause_2025/templates/closed.html.ep | 7 + lib/pause_2025/templates/disabled.html.ep | 5 + .../templates/email/admin/edit_ml.email.ep | 25 + .../admin/user/onetime_password.email.ep | 26 + .../email/admin/user/welcome_ml.email.ep | 13 + .../email/admin/user/welcome_user.email.ep | 35 + .../templates/email/public/mailpw.email.ep | 28 + .../email/public/request_id.email.ep | 25 + .../email/user/change_passwd.email.ep | 15 + .../templates/email/user/cred/edit.email.ep | 18 + .../email/user/delete_files.email.ep | 21 + .../templates/email/user/edit_uris.email.ep | 34 + .../templates/email/user/reindex.email.ep | 15 + .../email/user/reset_version.email.ep | 12 + .../email/user/uri/submission.email.ep | 30 + .../templates/layouts/layout.html.ep | 100 +++ .../templates/mlrepr/select_ml_action.html.ep | 44 ++ .../templates/mlrepr/show_ml_repr.html.ep | 32 + lib/pause_2025/templates/pause_doc.html.ep | 4 + lib/pause_2025/templates/public/admin.html.ep | 8 + .../templates/public/mailpw.html.ep | 21 + .../templates/public/pumpkin.html.ep | 8 + .../templates/public/request_id/_form.html.ep | 63 ++ .../public/request_id/request.html.ep | 48 ++ lib/pause_2025/templates/root/index.html.ep | 34 + .../templates/user/change_passwd.html.ep | 43 ++ .../templates/user/cred/edit.html.ep | 151 ++++ .../distperms/giveup_dist_comaint.html.ep | 75 ++ .../user/distperms/make_dist_comaint.html.ep | 92 +++ .../user/distperms/move_dist_primary.html.ep | 87 +++ .../templates/user/distperms/peek.html.ep | 113 +++ .../distperms/remove_dist_comaint.html.ep | 79 +++ .../distperms/remove_dist_primary.html.ep | 96 +++ .../templates/user/edit_uris.html.ep | 83 +++ .../templates/user/files/delete.html.ep | 58 ++ .../templates/user/files/show.html.ep | 43 ++ .../user/perms/_share_makeco.html.ep | 64 ++ .../user/perms/_share_movepr.html.ep | 52 ++ .../user/perms/_share_remocos.html.ep | 48 ++ .../user/perms/_share_remome.html.ep | 47 ++ .../user/perms/_share_remopr.html.ep | 50 ++ .../user/perms/giveup_comaint.html.ep | 75 ++ .../templates/user/perms/make_comaint.html.ep | 90 +++ .../templates/user/perms/move_primary.html.ep | 81 +++ .../templates/user/perms/peek.html.ep | 95 +++ .../user/perms/remove_comaint.html.ep | 80 +++ .../user/perms/remove_primary.html.ep | 92 +++ .../templates/user/perms/share.html.ep | 159 +++++ lib/pause_2025/templates/user/reindex.html.ep | 58 ++ .../templates/user/reset_version.html.ep | 71 ++ .../templates/user/show_ml_repr.html.ep | 2 + .../templates/user/tail_logfile.html.ep | 21 + .../templates/user/uri/_continued.html.ep | 64 ++ lib/pause_2025/templates/user/uri/add.html.ep | 133 ++++ 100 files changed, 9864 insertions(+) create mode 100644 lib/pause_2025/PAUSE/Web.pm create mode 100644 lib/pause_2025/PAUSE/Web/App/Disabled.pm create mode 100644 lib/pause_2025/PAUSE/Web/App/Index.pm create mode 100644 lib/pause_2025/PAUSE/Web/Config.pm create mode 100644 lib/pause_2025/PAUSE/Web/Context.pm create mode 100644 lib/pause_2025/PAUSE/Web/Controller/Admin.pm create mode 100644 lib/pause_2025/PAUSE/Web/Controller/Admin/ManageId.pm create mode 100644 lib/pause_2025/PAUSE/Web/Controller/Admin/User.pm create mode 100644 lib/pause_2025/PAUSE/Web/Controller/Mlrepr.pm create mode 100644 lib/pause_2025/PAUSE/Web/Controller/Public.pm create mode 100644 lib/pause_2025/PAUSE/Web/Controller/Public/RequestId.pm create mode 100644 lib/pause_2025/PAUSE/Web/Controller/Root.pm create mode 100644 lib/pause_2025/PAUSE/Web/Controller/User.pm create mode 100644 lib/pause_2025/PAUSE/Web/Controller/User/Cred.pm create mode 100644 lib/pause_2025/PAUSE/Web/Controller/User/Distperms.pm create mode 100644 lib/pause_2025/PAUSE/Web/Controller/User/Files.pm create mode 100644 lib/pause_2025/PAUSE/Web/Controller/User/Perms.pm create mode 100644 lib/pause_2025/PAUSE/Web/Controller/User/Uri.pm create mode 100644 lib/pause_2025/PAUSE/Web/Exception.pm create mode 100644 lib/pause_2025/PAUSE/Web/Middleware/Auth/Basic.pm create mode 100644 lib/pause_2025/PAUSE/Web/Plugin/ConfigPerRequest.pm create mode 100644 lib/pause_2025/PAUSE/Web/Plugin/Delegate.pm create mode 100644 lib/pause_2025/PAUSE/Web/Plugin/EditUtils.pm create mode 100644 lib/pause_2025/PAUSE/Web/Plugin/FixAction.pm create mode 100644 lib/pause_2025/PAUSE/Web/Plugin/GetActiveUserRecord.pm create mode 100644 lib/pause_2025/PAUSE/Web/Plugin/GetUserMeta.pm create mode 100644 lib/pause_2025/PAUSE/Web/Plugin/IsPauseClosed.pm create mode 100644 lib/pause_2025/PAUSE/Web/Plugin/MyURL.pm create mode 100644 lib/pause_2025/PAUSE/Web/Plugin/RenderYAML.pm create mode 100644 lib/pause_2025/PAUSE/Web/Plugin/ServePauseDoc.pm create mode 100644 lib/pause_2025/PAUSE/Web/Plugin/SessionCounted.pm create mode 100644 lib/pause_2025/PAUSE/Web/Plugin/TextFormat.pm create mode 100644 lib/pause_2025/PAUSE/Web/Plugin/UserRegistration.pm create mode 100644 lib/pause_2025/PAUSE/Web/Plugin/WrapAction.pm create mode 100644 lib/pause_2025/PAUSE/Web/Util/Encode.pm create mode 100644 lib/pause_2025/PAUSE/Web/Util/RewriteXHTML.pm create mode 100644 lib/pause_2025/TODO create mode 100644 lib/pause_2025/templates/_closed.html.ep create mode 100644 lib/pause_2025/templates/_debug.html.ep create mode 100644 lib/pause_2025/templates/_user_menu.html.ep create mode 100644 lib/pause_2025/templates/_user_status.html.ep create mode 100644 lib/pause_2025/templates/admin/edit_ml.html.ep create mode 100644 lib/pause_2025/templates/admin/email_for_admin.html.ep create mode 100644 lib/pause_2025/templates/admin/manage_id/manage.html.ep create mode 100644 lib/pause_2025/templates/admin/select_user.html.ep create mode 100644 lib/pause_2025/templates/admin/user/add.html.ep create mode 100644 lib/pause_2025/templates/closed.html.ep create mode 100644 lib/pause_2025/templates/disabled.html.ep create mode 100644 lib/pause_2025/templates/email/admin/edit_ml.email.ep create mode 100644 lib/pause_2025/templates/email/admin/user/onetime_password.email.ep create mode 100644 lib/pause_2025/templates/email/admin/user/welcome_ml.email.ep create mode 100644 lib/pause_2025/templates/email/admin/user/welcome_user.email.ep create mode 100644 lib/pause_2025/templates/email/public/mailpw.email.ep create mode 100644 lib/pause_2025/templates/email/public/request_id.email.ep create mode 100644 lib/pause_2025/templates/email/user/change_passwd.email.ep create mode 100644 lib/pause_2025/templates/email/user/cred/edit.email.ep create mode 100644 lib/pause_2025/templates/email/user/delete_files.email.ep create mode 100644 lib/pause_2025/templates/email/user/edit_uris.email.ep create mode 100644 lib/pause_2025/templates/email/user/reindex.email.ep create mode 100644 lib/pause_2025/templates/email/user/reset_version.email.ep create mode 100644 lib/pause_2025/templates/email/user/uri/submission.email.ep create mode 100644 lib/pause_2025/templates/layouts/layout.html.ep create mode 100644 lib/pause_2025/templates/mlrepr/select_ml_action.html.ep create mode 100644 lib/pause_2025/templates/mlrepr/show_ml_repr.html.ep create mode 100644 lib/pause_2025/templates/pause_doc.html.ep create mode 100644 lib/pause_2025/templates/public/admin.html.ep create mode 100644 lib/pause_2025/templates/public/mailpw.html.ep create mode 100644 lib/pause_2025/templates/public/pumpkin.html.ep create mode 100644 lib/pause_2025/templates/public/request_id/_form.html.ep create mode 100644 lib/pause_2025/templates/public/request_id/request.html.ep create mode 100644 lib/pause_2025/templates/root/index.html.ep create mode 100644 lib/pause_2025/templates/user/change_passwd.html.ep create mode 100644 lib/pause_2025/templates/user/cred/edit.html.ep create mode 100644 lib/pause_2025/templates/user/distperms/giveup_dist_comaint.html.ep create mode 100644 lib/pause_2025/templates/user/distperms/make_dist_comaint.html.ep create mode 100644 lib/pause_2025/templates/user/distperms/move_dist_primary.html.ep create mode 100644 lib/pause_2025/templates/user/distperms/peek.html.ep create mode 100644 lib/pause_2025/templates/user/distperms/remove_dist_comaint.html.ep create mode 100644 lib/pause_2025/templates/user/distperms/remove_dist_primary.html.ep create mode 100644 lib/pause_2025/templates/user/edit_uris.html.ep create mode 100644 lib/pause_2025/templates/user/files/delete.html.ep create mode 100644 lib/pause_2025/templates/user/files/show.html.ep create mode 100644 lib/pause_2025/templates/user/perms/_share_makeco.html.ep create mode 100644 lib/pause_2025/templates/user/perms/_share_movepr.html.ep create mode 100644 lib/pause_2025/templates/user/perms/_share_remocos.html.ep create mode 100644 lib/pause_2025/templates/user/perms/_share_remome.html.ep create mode 100644 lib/pause_2025/templates/user/perms/_share_remopr.html.ep create mode 100644 lib/pause_2025/templates/user/perms/giveup_comaint.html.ep create mode 100644 lib/pause_2025/templates/user/perms/make_comaint.html.ep create mode 100644 lib/pause_2025/templates/user/perms/move_primary.html.ep create mode 100644 lib/pause_2025/templates/user/perms/peek.html.ep create mode 100644 lib/pause_2025/templates/user/perms/remove_comaint.html.ep create mode 100644 lib/pause_2025/templates/user/perms/remove_primary.html.ep create mode 100644 lib/pause_2025/templates/user/perms/share.html.ep create mode 100644 lib/pause_2025/templates/user/reindex.html.ep create mode 100644 lib/pause_2025/templates/user/reset_version.html.ep create mode 100644 lib/pause_2025/templates/user/show_ml_repr.html.ep create mode 100644 lib/pause_2025/templates/user/tail_logfile.html.ep create mode 100644 lib/pause_2025/templates/user/uri/_continued.html.ep create mode 100644 lib/pause_2025/templates/user/uri/add.html.ep diff --git a/lib/pause_2025/PAUSE/Web.pm b/lib/pause_2025/PAUSE/Web.pm new file mode 100644 index 000000000..f2ba1ae2f --- /dev/null +++ b/lib/pause_2025/PAUSE/Web.pm @@ -0,0 +1,103 @@ +package PAUSE::Web; + +use Mojo::Base "Mojolicious"; +use MojoX::Log::Dispatch::Simple; +use Digest::SHA1 qw/sha1_hex/; + +has pause => sub { Carp::confess "requires PAUSE::Web::Context" }; + +sub startup { + my $app = shift; + + $app->moniker("pause-web"); + + $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); + + # Set random secrets to keep mojo session secure + $app->secrets([sha1_hex($$.time)]); + + # Fix template path for now + unshift @{$app->renderer->paths}, $app->home->rel_file("lib/pause_2017/templates"); + + # Fix static path + unshift @{$app->static->paths}, $app->home->rel_file("htdocs"); + + # Load plugins to modify path/set stash values/provide helper methods + $app->plugin("WithCSRFProtection"); + $app->plugin("PAUSE::Web::Plugin::ConfigPerRequest"); + $app->plugin("PAUSE::Web::Plugin::IsPauseClosed"); + $app->plugin("PAUSE::Web::Plugin::GetActiveUserRecord"); + $app->plugin("PAUSE::Web::Plugin::GetUserMeta"); + $app->plugin("PAUSE::Web::Plugin::ServePauseDoc"); + $app->plugin("PAUSE::Web::Plugin::FixAction"); + $app->plugin("PAUSE::Web::Plugin::WrapAction"); + $app->plugin("PAUSE::Web::Plugin::EditUtils"); + $app->plugin("PAUSE::Web::Plugin::Delegate"); + $app->plugin("PAUSE::Web::Plugin::SessionCounted"); + $app->plugin("PAUSE::Web::Plugin::MyURL"); + $app->plugin("PAUSE::Web::Plugin::RenderYAML"); + $app->plugin("PAUSE::Web::Plugin::TextFormat"); + $app->plugin("PAUSE::Web::Plugin::UserRegistration"); + + # Check HTTP headers and set stash + my $r = $app->routes->under("/")->to("root#check"); + + # Public Menu + my $public = $r->under("/query"); + $public->any("/")->to("root#index"); + for my $group ($app->pause->config->public_groups) { + for my $name ($app->pause->config->action_names_for($group)) { + my $action = $app->pause->config->action($name); + for my $method (qw/get post/) { + my $route = $public->$method("/$name"); + $route->with_csrf_protection if $method eq "post" and $action->{x_csrf_protection}; + $route->to($action->{x_mojo_to}); + } + } + } + # change_passwd is public when it is used for password recovery + my $action = $app->pause->config->action('change_passwd'); + for my $method (qw/get post/) { + my $route = $public->$method("/change_passwd"); + $route->with_csrf_protection if $method eq "post" and $action->{x_csrf_protection}; + $route->to($action->{x_mojo_to}); + } + + # Private/User Menu + my $private = $r->under("/authenquery")->to("root#auth"); + $private->any("/")->to("root#index"); + for my $group ($app->pause->config->all_groups) { + for my $name ($app->pause->config->action_names_for($group)) { + my $action = $app->pause->config->action($name); + for my $method (qw/get post/) { + my $route = $private->$method("/$name"); + $route->with_csrf_protection if $method eq "post" and $action->{x_csrf_protection}; + $route->to($action->{x_mojo_to}); + } + } + } +} + +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 }; +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/App/Disabled.pm b/lib/pause_2025/PAUSE/Web/App/Disabled.pm new file mode 100644 index 000000000..ef38fd5cc --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/App/Disabled.pm @@ -0,0 +1,31 @@ +package PAUSE::Web::App::Disabled; + +use Mojo::Base -base; +use Plack::Request; +use Plack::Response; + +sub to_app { + my $self = shift; + + return sub { + my $req = Plack::Request->new(shift); + my $res = $req->new_response(200); + $res->content_type("text/html"); + open my $fh, "/etc/PAUSE.CLOSED"; + local $/; + my $mess = <$fh>; + $mess ||= qq{please retry in a few seconds}; + $res->body([<<"HTML"]); + + +Closed for Maintanance + +

Dear visitor,

}, +$mess, + +HTML + $res->finalize; + }; +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/App/Index.pm b/lib/pause_2025/PAUSE/Web/App/Index.pm new file mode 100644 index 000000000..b56c65318 --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/App/Index.pm @@ -0,0 +1,61 @@ +package PAUSE::Web::App::Index; + +use Mojo::Base -base; +use Plack::Request; +use Plack::Response; +use HTTP::Status qw/:constants/; + +sub to_app { + my $self = shift; + + return sub { + my $req = Plack::Request->new(shift); + my $res = $self->dispatch($req); + return $res if ref $res; + [$res =~ /^\d+$/ ? $res : 500, [], [$res]]; + }; +} + + +sub dispatch { + my ($self, $req) = @_; + + my $method = $req->method; + my $redir_to = $req->base; + my $is_ssl = $req->headers->header("X-pause-is-SSL") || 1; + if ($is_ssl) { + $redir_to->scheme("https"); + } + if ($method eq "GET" && $redir_to->path eq "/" && $req->env->{QUERY_STRING}) { + my $args = $req->env->{QUERY_STRING}; + # warn "Returning SERVER_ERROR: the_request[$the_request]uri[$uri]args[$args]"; + # return SERVER_ERROR; + $redir_to->path("/pause/query"); + $args =~ s|/$||; + $args =~ s|\s.*||; + $redir_to->query($args) if $args; + # warn "Statistics: Redirecting the_request[$the_request]redir_to[$redir_to]"; + my $res = $req->new_response(HTTP_MOVED_PERMANENTLY); + $res->headers->header("Location", $redir_to); + return $res->finalize; + } + + my $uri = $req->path; + #my $host = $r->server->server_hostname; + #my $args = $r->args; + #warn "index-uri[$uri]host[$host]args[$args]"; + return HTTP_NOT_FOUND unless $uri eq "/" || $uri eq "/index.html"; + + #my(%redir) = ( + # "/" => "query", + # "/index.html" => "query?ACTION=pause_05news", + # ); + # $r->internal_redirect_handler("/query"); + $redir_to->path("/pause/query"); + $redir_to->query("ACTION=pause_05news") if $uri eq "/index.html"; + my $res = $req->new_response(HTTP_MOVED_PERMANENTLY); + $res->headers->header("Location", $redir_to); + return $res->finalize; +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Config.pm b/lib/pause_2025/PAUSE/Web/Config.pm new file mode 100644 index 000000000..04d4e1230 --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Config.pm @@ -0,0 +1,656 @@ +package PAUSE::Web::Config; + +use Mojo::Base -base; +use PAUSE; + +our %Actions = ( + # PUBLIC + request_id => { + x_mojo_to => "public-request_id#request", + verb => "Request PAUSE account", + priv => "public", + cat => "00reg/01", + desc => "Apply for a PAUSE account.", + method => 'POST', + x_form => { + pause99_request_id_fullname => {form_type => "text_field"}, + pause99_request_id_email => {form_type => "text_field"}, + pause99_request_id_homepage => {form_type => "text_field"}, + pause99_request_id_userid => {form_type => "text_field"}, + pause99_request_id_rationale => {form_type => "text_area"}, + SUBMIT_pause99_request_id_sub => {form_type => "submit_button"}, + url => {form_type => "text_field"}, # bot-trap + }, + }, + mailpw => { + x_mojo_to => "public#mailpw", + verb => "Forgot Password?", + priv => "public", + cat => "00urg/01", + desc => "A passwordmailer that sends you a password that enables you to set a new password.", + method => 'POST', + x_csrf_protection => 1, + x_form => { + ABRA => {form_type => "hidden_field"}, + pause99_mailpw_1 => {form_type => "text_field"}, + pause99_mailpw_sub => {form_type => "submit_button"}, + }, + }, + pause_04about => { + x_mojo_to => "public#about", + verb => "About PAUSE", + priv => "public", + cat => "01self/04a", + desc => "Same as modules/04pause.html on any CPAN server", + }, + pause_04imprint => { + x_mojo_to => "public#imprint", + verb => "Imprint/Impressum", + priv => "public", + cat => "01self/06b", + }, + pause_05news => { + x_mojo_to => "public#news", + verb => "PAUSE News", + priv => "public", + cat => "01self/05", + desc => "What's going on on PAUSE", + }, + pause_06history => { + x_mojo_to => "public#history", + verb => "PAUSE History", + priv => "public", + cat => "01self/06", + desc => "Old News", + }, + pause_namingmodules => { + x_mojo_to => "public#naming", + verb => "On The Naming of Modules", + priv => "public", + cat => "01self/04c", + desc => "A couple of suggestions that hopefully get you on track", + }, + pause_operating_model => { + x_mojo_to => "public#operating_model", + verb => "PAUSE Operating Model", + priv => "public", + cat => "01self/04b", + desc => "How the PAUSE admins run PAUSE", + has_title => 1, + }, + pause_privacy_policy => { + x_mojo_to => "public#privacy_policy", + verb => "PAUSE Privacy Policy", + priv => "public", + cat => "01self/04c", + desc => "Your rights as a user of PAUSE", + has_title => 1, + }, + who_pumpkin => { + x_mojo_to => "public#pumpkin", + verb => "List of pumpkins", + priv => "public", + cat => "02serv/05", + desc => "A list, also available as YAML", + }, + who_admin => { + x_mojo_to => "public#admin", + verb => "List of admins", + priv => "public", + cat => "02serv/06", + desc => "A list, also available as YAML", + }, + + # USER + # USER/FILES + + add_uri => { + x_mojo_to => "user-uri#add", + verb => "Upload a file to CPAN", + priv => "user", + cat => "User/01Files/01up", + desc => "This is the heart of the Upload Server, the page most heavily used on PAUSE.", + method => 'POST', + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + CAN_MULTIPART => {form_type => "hidden_field"}, + pause99_add_uri_subdirscrl => {form_type => "select_field"}, + pause99_add_uri_subdirtext => {form_type => "text_field"}, + pause99_add_uri_httpupload => {form_type => "file_field"}, + SUBMIT_pause99_add_uri_httpupload => {form_type => "submit_button"}, + pause99_add_uri_uri => {form_type => "text_field"}, + SUBMIT_pause99_add_uri_uri => {form_type => "submit_button"}, + }, + }, + show_files => { + x_mojo_to => "user-files#show", + verb => "Show my files", + priv => "user", + cat => "User/01Files/02show", + desc => "find . -ls resemblance", + }, + edit_uris => { + x_mojo_to => "user#edit_uris", + verb => "Repair a Pending Upload", + priv => "user", + cat => "User/01Files/03rep", + desc => "When an upload you requested hangs for some reason, you can go here and edit the file to be uploaded.", + method => 'POST', + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + pause99_edit_uris_3 => {form_type => "select_field"}, # distributions + pause99_edit_uris_2 => {form_type => "submit_button"}, # select target + pause99_edit_uris_uri => {form_type => "text_field"}, # file to upload + pause99_edit_uris_4 => {form_type => "submit_button"}, # upload + }, + }, + delete_files => { + x_mojo_to => "user-files#delete", + verb => "Delete Files", + priv => "user", + cat => "User/01Files/04del", + desc => "Schedule files for deletion. There is a delay until the deletion really happens. Until then you can also undelete files here.", + method => 'POST', + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + SUBMIT_pause99_delete_files_delete => {form_type => "submit_button"}, + SUBMIT_pause99_delete_files_undelete => {form_type => "submit_button"}, + pause99_delete_files_FILE => {form_type => "check_box"}, + } + }, + + # User/Permissions + + peek_perms => { + x_mojo_to => "user-perms#peek", + verb => "View Permissions per module", + priv => "user", + cat => "User/04Permissions/11", + desc => "Whose uploads of what are being indexed on PAUSE", + x_form => { + pause99_peek_perms_by => {form_type => "select_field"}, + pause99_peek_perms_query => {form_type => "text_field"}, + pause99_peek_perms_sub => {form_type => "submit_button"}, + }, + display => 0, + }, + share_perms => { + x_mojo_to => "user-perms#share", + verb => "Change Permissions per module", + priv => "user", + cat => "User/04Permissions/12", + desc => "Enable other users to upload a module for any of your namespaces, manage your own permissions.", + method => 'POST', + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + lsw => {form_type => "hidden_field"}, + # pause99_edit_mod_3 => {form_type => "select_field"}, + pause99_share_perms_pr_m => {form_type => "select_field"}, + weaksubmit_pause99_share_perms_movepr => {form_type => "submit_button"}, + weaksubmit_pause99_share_perms_remopr => {form_type => "submit_button"}, + pause99_share_perms_makeco_m => {form_type => "select_field"}, + weaksubmit_pause99_share_perms_makeco => {form_type => "submit_button"}, + weaksubmit_pause99_share_perms_remocos => {form_type => "submit_button"}, + pause99_share_perms_remome_m => {form_type => "select_field"}, + weaksubmit_pause99_share_perms_remome => {form_type => "submit_button"}, + }, + x_form_movepr => { + pause99_share_perms_pr_m => {form_type => "select_field"}, + pause99_share_perms_movepr_a => {form_type => "text_field"}, + SUBMIT_pause99_share_perms_movepr => {form_type => "submit_button"}, + }, + x_form_remopr => { + pause99_share_perms_pr_m => {form_type => "select_field"}, + SUBMIT_pause99_share_perms_remopr => {form_type => "select_field"}, + }, + x_form_makeco => { + pause99_share_perms_makeco_m => {form_type => "select_field"}, + pause99_share_perms_makeco_a => {form_type => "text_field"}, + SUBMIT_pause99_share_perms_makeco => {form_type => "submit_button"}, + }, + x_form_remocos => { + pause99_share_perms_remocos_tuples => {form_type => "select_field"}, + SUBMIT_pause99_share_perms_remocos => {form_type => "submit_button"}, + }, + x_form_remome => { + pause99_share_perms_remome_m => {form_type => "select_field"}, + SUBMIT_pause99_share_perms_remome => {form_type => "submit_button"}, + }, + }, + move_primary => { + x_mojo_to => "user-perms#move_primary", + verb => "Transfer Primary Permissions per module", + priv => "user", + cat => "User/04Permissions/13", + desc => "Transfer primary maintainership status to somebody else (you become co-maintainer).", + method => 'POST', + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + lsw => {form_type => "hidden_field"}, + pause99_share_perms_pr_m => {form_type => "select_field"}, + pause99_share_perms_movepr_a => {form_type => "text_field"}, + SUBMIT_pause99_share_perms_movepr => {form_type => "submit_button"}, + }, + display => 0, + }, + remove_primary => { + x_mojo_to => "user-perms#remove_primary", + verb => "Put Up My Module(s) For Adoption per module", + priv => "user", + cat => "User/04Permissions/14", + desc => "Give up primary maintainership status (abandoning it without transfering it to someone else).", + method => 'POST', + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + lsw => {form_type => "hidden_field"}, + pause99_share_perms_pr_m => {form_type => "select_field"}, + SUBMIT_pause99_share_perms_remopr => {form_type => "select_field"}, + }, + display => 0, + }, + make_comaint => { + x_mojo_to => "user-perms#make_comaint", + verb => "Add Comaintainers per module", + priv => "user", + cat => "User/04Permissions/15", + desc => "Make somebody else co-maintainer.", + method => 'POST', + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + lsw => {form_type => "hidden_field"}, + pause99_share_perms_makeco_m => {form_type => "select_field"}, + pause99_share_perms_makeco_a => {form_type => "text_field"}, + SUBMIT_pause99_share_perms_makeco => {form_type => "submit_button"}, + }, + display => 0, + }, + remove_comaint => { + x_mojo_to => "user-perms#remove_comaint", + verb => "Remove Comaintainers per module", + priv => "user", + cat => "User/04Permissions/16", + desc => "Remove a co-maintainer.", + method => 'POST', + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + lsw => {form_type => "hidden_field"}, + pause99_share_perms_remocos_tuples => {form_type => "select_field"}, + SUBMIT_pause99_share_perms_remocos => {form_type => "submit_button"}, + }, + display => 0, + }, + giveup_comaint => { + x_mojo_to => "user-perms#giveup_comaint", + verb => "Give up (Module's) co-maintainership status", + priv => "user", + cat => "User/04Permissions/17", + desc => "Give up co-maintainership status.", + method => 'POST', + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + lsw => {form_type => "hidden_field"}, + pause99_share_perms_remome_m => {form_type => "select_field"}, + SUBMIT_pause99_share_perms_remome => {form_type => "submit_button"}, + }, + display => 0, + }, + peek_dist_perms => { + x_mojo_to => "user-distperms#peek", + verb => "View Permissions", + priv => "user", + cat => "User/04Permissions/01", + desc => "Whose uploads of what are being indexed on PAUSE", + x_form => { + pause99_peek_dist_perms_by => {form_type => "select_field"}, + pause99_peek_dist_perms_query => {form_type => "text_field"}, + pause99_peek_dist_perms_sub => {form_type => "submit_button"}, + }, + }, + move_dist_primary => { + x_mojo_to => "user-distperms#move_dist_primary", + verb => "Transfer Primary Permissions", + priv => "user", + cat => "User/04Permissions/02", + desc => "Transfer distribution's primary maintainership status to somebody else (you become co-maintainer).", + method => 'POST', + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + lsw => {form_type => "hidden_field"}, + pause99_make_dist_primary_d => {form_type => "select_field"}, + pause99_make_dist_primary_a => {form_type => "text_field"}, + SUBMIT_pause99_make_dist_primary => {form_type => "submit_button"}, + }, + }, + remove_dist_primary => { + x_mojo_to => "user-distperms#remove_dist_primary", + verb => "Put Up My Distribution(s) For Adoption", + priv => "user", + cat => "User/04Permissions/03", + desc => "Give up distribution's primary maintainership status (abandoning it without transfering it to someone else).", + method => 'POST', + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + lsw => {form_type => "hidden_field"}, + pause99_remove_dist_primary_d => {form_type => "select_field"}, + SUBMIT_pause99_remove_dist_primary => {form_type => "select_field"}, + }, + }, + make_dist_comaint => { + x_mojo_to => "user-distperms#make_dist_comaint", + verb => "Add Comaintainers", + priv => "user", + cat => "User/04Permissions/04", + desc => "Make somebody else co-maintainer of a distribution.", + method => 'POST', + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + lsw => {form_type => "hidden_field"}, + pause99_make_dist_comaint_d => {form_type => "select_field"}, + pause99_make_dist_comaint_a => {form_type => "text_field"}, + SUBMIT_pause99_make_dist_comaint => {form_type => "submit_button"}, + }, + }, + remove_dist_comaint => { + x_mojo_to => "user-distperms#remove_dist_comaint", + verb => "Remove Comaintainers", + priv => "user", + cat => "User/04Permissions/05", + desc => "Remove a distribution's co-maintainer.", + method => 'POST', + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + lsw => {form_type => "hidden_field"}, + pause99_remove_dist_comaint_tuples => {form_type => "select_field"}, + SUBMIT_pause99_remove_dist_comaint => {form_type => "submit_button"}, + }, + }, + giveup_dist_comaint => { + x_mojo_to => "user-distperms#giveup_dist_comaint", + verb => "Give up co-maintainership status", + priv => "user", + cat => "User/04Permissions/06", + desc => "Give up distribution's co-maintainership status.", + method => 'POST', + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + lsw => {form_type => "hidden_field"}, + pause99_giveup_dist_comaint_d => {form_type => "select_field"}, + SUBMIT_pause99_giveup_dist_comaint => {form_type => "submit_button"}, + }, + }, + + # User/Util + + tail_logfile => { + x_mojo_to => "user#tail_logfile", + verb => "Tail Daemon Logfile", + priv => "user", + cat => "User/05Utils/06", + x_form => { + pause99_tail_logfile_1 => {form_type => "select_field"}, # how many lines to tail + pause99_tail_logfile_sub => {form_type => "submit_button"}, + } + }, + reindex => { + x_mojo_to => "user#reindex", + verb => "Force Reindexing", + priv => "user", + cat => "User/05Utils/02", + desc => "Tell the indexer to index a file again (e.g. after a change in the perms table)", + method => 'POST', + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + SUBMIT_pause99_reindex_delete => {form_type => "submit_button"}, + pause99_reindex_FILE => {form_type => "check_box"}, + }, + }, + reset_version => { + x_mojo_to => "user#reset_version", + verb => "Reset Version", + priv => "user", + cat => "User/05Utils/02", + desc => "Overrule the record of the current version number of a module that the indexer uses and set it to 'undef'", + method => 'POST', + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + SUBMIT_pause99_reset_version_forget => {form_type => "submit_button"}, + pause99_reset_version_PKG => {form_type => "check_box"}, + }, + }, + + # User/Account + + change_passwd => { + x_mojo_to => "user#change_passwd", + verb => "Change Password", + priv => "user", + cat => "User/06Account/02", + desc => "Change your password any time you want.", + method => 'POST', + x_csrf_protection => 1, + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + ABRA => {form_type => "hidden_field"}, + pause99_change_passwd_pw1 => {form_type => "password_field"}, + pause99_change_passwd_pw2 => {form_type => "password_field"}, + pause99_change_passwd_sub => {form_type => "submit_button"}, + }, + }, + edit_cred => { + x_mojo_to => "user-cred#edit", + verb => "Edit Account Info", + priv => "user", + cat => "User/06Account/01", + desc => "Edit your user name, your email addresses (both public and secret one), change the URL of your homepage.", + method => 'POST', + x_csrf_protection => 1, + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + pause99_edit_cred_fullname => {form_type => "text_field"}, + pause99_edit_cred_asciiname => {form_type => "text_field"}, + pause99_edit_cred_email => {form_type => "text_field"}, + pause99_edit_cred_secretemail => {form_type => "text_field"}, + pause99_edit_cred_homepage => {form_type => "text_field"}, + pause99_edit_cred_cpan_mail_alias => {form_type => "radio_button"}, + pause99_edit_cred_ustatus => {form_type => "check_box"}, # to delete + pause99_edit_cred_sub => {form_type => "submit_button"}, + }, + }, + pause_logout => { + x_mojo_to => "user#pause_logout", + verb => "About Logging Out", + priv => "user", + cat => "User/06Account/04", + }, + + # ADMIN+mlrep+modlistmaint + + select_ml_action => { + x_mojo_to => "mlrepr#select_ml_action", + verb => "Select Mailinglist/Action", + priv => "mlrepr", + cat => "09root/02", + desc => "Representatives of mailing lists have their special menu here.", + method => 'POST', + x_form => { + HIDDENNAME => {form_type => "select_field"}, + ACTIONREQ => {form_type => "select_field"}, + pause99_select_ml_action_sub => {form_type => "submit_button"}, + }, + }, + show_ml_repr => { + x_mojo_to => "mlrepr#show_ml_repr", + verb => "Show Mailinglist Reps", + priv => "mlrepr", + cat => "09root/04", + desc => "Admins and the representatives themselves can lookup who is elected to be representative of a mailing list.", + }, + + add_user => { + x_mojo_to => "admin-user#add", + verb => "Add a User or Mailinglist", + priv => "admin", + cat => "01usr/01add", + desc => "Admins can add users or mailinglists.", + method => 'POST', + x_form => { + SUBMIT_pause99_add_user_Soundex => {form_type => "submit_button"}, + SUBMIT_pause99_add_user_Metaphone => {form_type => "submit_button"}, + SUBMIT_pause99_add_user_Definitely => {form_type => "submit_button"}, + pause99_add_user_userid => {form_type => "text_field"}, + pause99_add_user_fullname => {form_type => "text_field"}, + pause99_add_user_email => {form_type => "text_field"}, + pause99_add_user_homepage => {form_type => "text_field"}, + pause99_add_user_subscribe => {form_type => "text_field"}, + pause99_add_user_memo => {form_type => "text_area"}, + }, + }, + manage_id_requests => { + x_mojo_to => "admin-manage_id#manage", + verb => "Manage a registration request (alpha)", + priv => "admin", + cat => "01usr/01rej", + desc => "show/reject open registration requests", + method => 'POST', + }, + edit_ml => { + x_mojo_to => "admin#edit_ml", + verb => "Edit a Mailinglist", + priv => "admin", + cat => "01usr/02", + desc => "Admins and mailing list representatives can change the name, address and description of a mailing list.", + method => 'POST', + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + pause99_edit_ml_3 => {form_type => "select_field"}, # mailing lists + pause99_edit_ml_2 => {form_type => "submit_button"}, # select ml + pause99_edit_ml_maillistname => {form_type => "text_field"}, + pause99_edit_ml_address => {form_type => "text_field"}, + pause99_edit_ml_subscribe => {form_type => "text_area"}, + pause99_edit_ml_4 => {form_type => "submit_button"}, # update + }, + }, + email_for_admin => { + x_mojo_to => "admin#email_for_admin", + verb => "Look up the forward email address", + priv => "admin", + cat => "01usr/01look", + desc => "Admins can look where email should go", + }, + select_user => { + x_mojo_to => "admin#select_user", + verb => "Select User/Action", + priv => "admin", + cat => "01usr/03", + desc => "Admins can access PAUSE as-if they were somebody else. Here they select a user/action pair.", + method => 'POST', + x_form => { + HIDDENNAME => {form_type => "select_field"}, + ACTIONREQ => {form_type => "select_field"}, + pause99_select_user_sub => {form_type => "submit_button"}, + }, + }, +); + +our @AllowAdminTakeover = qw( + add_uri + change_passwd + delete_files + edit_cred + edit_ml + edit_uris + reindex + reset_version + share_perms + move_primary + remove_primary + make_comaint + remove_comaint + giveup_comaint + move_dist_primary + remove_dist_primary + make_dist_comaint + remove_dist_comaint + giveup_dist_comaint +); + +our @AllowMlreprTakeover = qw( + edit_ml + reset_version + share_perms + move_primary + remove_primary + make_comaint + remove_comaint + giveup_comaint + move_dist_primary + remove_dist_primary + make_dist_comaint + remove_dist_comaint + giveup_dist_comaint +); + +sub allow_admin_takeover { @AllowAdminTakeover } +sub allow_mlrepr_takeover { @AllowMlreprTakeover } + +sub action_names_for { + my ($self, $priv) = @_; + grep {$Actions{$_}{priv} eq $priv} keys %Actions; +} + +sub action { + my ($self, $name) = @_; + $name && exists $Actions{$name} ? $Actions{$name} : {}; +} + +sub has_action { + my ($self, $name) = @_; + exists $Actions{$name} ? 1 : 0; +} + +sub action_map_to_verb { + my ($self, @actions) = @_; + my %action_map; + for my $action (@actions) { + next unless exists $Actions{$action}; + my $verb = $Actions{$action}{verb} or next; + $action_map{$action} = $verb; + } + \%action_map; +} + +sub sort_allowed_group_actions { + my ($self, $group, $names) = @_; + map {$Actions{$_}{name} = $_; $Actions{$_}} + sort {$Actions{$a}{cat} cmp $Actions{$b}{cat}} + grep {$Actions{$_}{priv} eq $group} + @{$names || []}; +} + +our %GroupLabel = ( + public => "Public", + user => "User", + mlrepr => "Mailinglists", + admin => "Admin", +); + +our @PublicGroups = qw/public/; +our @AllGroups = qw/public user mlrepr admin/; +our @ExtraGroups = qw/mlrepr admin/; + +sub public_groups { @PublicGroups } +sub extra_groups { @ExtraGroups } +sub all_groups { @AllGroups } + +sub group_label { + my ($self, $group) = @_; + exists $GroupLabel{$group} ? $GroupLabel{$group} : Carp::confess "no label for $group"; +} + +our $Valid_Userid = qr/^[A-Z]{3,9}$/; + +sub valid_userid { $Valid_Userid } + +sub mailto_admins { join(",", @{$PAUSE::Config->{ADMINS}}) } + +1; diff --git a/lib/pause_2025/PAUSE/Web/Context.pm b/lib/pause_2025/PAUSE/Web/Context.pm new file mode 100644 index 000000000..c642afe69 --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Context.pm @@ -0,0 +1,213 @@ +package PAUSE::Web::Context; + +use Mojo::Base -base; +use Mojo::ByteStream; +use Log::Dispatch::Config; +use Encode; +use Sys::Hostname (); +use Email::Sender::Simple; +use Email::MIME; +use Data::Dumper; +use PAUSE::Web::Config; +use PAUSE::Web::Exception; + +our $VERSION = "1072"; + +has root => sub { Carp::confess "requires root" }; +has config => sub { PAUSE::Web::Config->new }; +has logger => sub { Log::Dispatch::Config->instance }; +has mailer => sub { Email::Sender::Simple->new }; + +sub init { + my $self = shift; + + my $root = $self->root; + Log::Dispatch::Config->configure("$root/etc/plack_log.conf.".($ENV{PLACK_ENV} // "development")); +} + + +sub version { + my $self = shift; + return $self->{VERSION} if defined $self->{VERSION}; + my $version = $VERSION; + for my $m (grep {! m!/Test/!} grep /pause_2017/, keys %INC) { + $m =~ s|/|::|g; + $m =~ s|\.pm$||; + my $v = $m->VERSION || 0; + warn "Warning: Strange versioning style in m[$m]v[$v]" if $v < 10; + $version = $v if $v > $version; + } + $version; +} + +sub hostname { + my $self = shift; + $PAUSE::Config->{SERVER_NAME} || Sys::Hostname::hostname(); +} + +sub log { + my ($self, $arg) = @_; + $self->logger->log(%$arg) +} + +### Database + +sub connect { + my $self = shift; + eval {$self->{DbHandle} ||= DBI->connect( + $PAUSE::Config->{MOD_DATA_SOURCE_NAME}, + $PAUSE::Config->{MOD_DATA_SOURCE_USER}, + $PAUSE::Config->{MOD_DATA_SOURCE_PW}, + { RaiseError => 1, + mysql_auto_reconnect => 1, + # mysql_enable_utf8 => 1, + } + )}; + return $self->{DbHandle} if $self->{DbHandle}; + $self->database_alert; +} + +sub authen_connect { + my $self = shift; + # local($SIG{PIPE}) = 'IGNORE'; + eval {$self->{DbHandle4Authen} ||= DBI->connect( + $PAUSE::Config->{AUTHEN_DATA_SOURCE_NAME}, + $PAUSE::Config->{AUTHEN_DATA_SOURCE_USER}, + $PAUSE::Config->{AUTHEN_DATA_SOURCE_PW}, + { RaiseError => 1, + mysql_auto_reconnect => 1, + # mysql_enable_utf8 => 1, + } + )}; + return $self->{DbHandle4Authen} if $self->{DbHandle4Authen}; + $self->database_alert; +} + +sub database_alert { + my $self = shift; + my $mess = Carp::longmess($@); + my $tsf = "$PAUSE::Config->{RUNDATA}/alert.db.not.available.ts"; + if (! -f $tsf or (time - (stat _)[9]) > 6*60*60) { + my $server = $self->hostname; + my $header = { + From => "database_alert", + To => $PAUSE::Config->{ADMIN}, + Subject => "PAUSE Database Alert $server", + }; + $self->send_mail($header, $mess); + open my $fh, ">", $tsf or warn "Could not open $tsf: $!"; + } + die PAUSE::Web::Exception->new(ERROR => <<"ERROR_END"); +Sorry, the PAUSE Database currently seems unavailable.
+Administration has been notified.
+Please try again later. +ERROR_END +} + +# A wrapper function for fetchrow_array and fetchrow_hashref +# XXX: Should mysql_enable_utf8 suffice? +sub fetchrow { + my ($self, $sth, $what) = @_; + + if (wantarray) { + my @arr = $sth->$what; + for (@arr) { + defined && /[^\000-\177]/ && Encode::_utf8_on($_); + } + return @arr; + } else { + my $ret = $sth->$what; + if (ref $ret) { + for my $k (keys %$ret) { + defined && /[^\000-\177]/ && Encode::_utf8_on($_) for $ret->{$k}; + } + return $ret; + } else { + defined && /[^\000-\177]/ && Encode::_utf8_on($_) for $ret; + return $ret; + } + } +} + +### Mailer + +sub prepare_sendto { + my ($self, $active_user, $pause_user, @admin) = @_; + + my %umailset; + my $name = $active_user->{asciiname} || $active_user->{fullname} || ""; + my $Uname = $pause_user->{asciiname} || $pause_user->{fullname} || ""; + if ($active_user->{secretemail}) { + $umailset{qq{"$name" <$active_user->{secretemail}>}} = 1; + } elsif ($active_user->{email}) { + $umailset{qq{"$name" <$active_user->{email}>}} = 1; + } + if ($active_user->{userid} ne $pause_user->{userid}) { + if ($pause_user->{secretemail}) { + $umailset{qq{"$Uname" <$pause_user->{secretemail}>}} = 1; + }elsif ($pause_user->{email}) { + $umailset{qq{"$Uname" <$pause_user->{email}>}} = 1; + } + } + my @to = keys %umailset; + push @to, @admin if @admin; + @to; +} + +sub send_mail_multi { + my ($self, $to, $header, $mailblurb) = @_; + warn "sending to[@$to]"; + warn "mailblurb[$mailblurb]"; + for my $to2 (@$to) { + $header->{To} = $to2; + $self->send_mail($header, "$mailblurb"); + } +} + +sub send_mail { + my ($self, $header, $blurb) = @_; + + my @hdebug = %$header; $self->log({level => "info", message => sprintf("hdebug[%s]", join "|", @hdebug) }); + $header->{From} ||= qq{"Perl Authors Upload Server" <$PAUSE::Config->{UPLOAD}>}; + $header->{"Reply-To"} ||= join ", ", @{$PAUSE::Config->{ADMINS}}; + + my $email = Email::MIME->create( + header_str => [%$header], + attributes => { + charset => 'utf-8', + content_type => 'text/plain', + encoding => 'quoted-printable', + }, + body_str => $blurb, + ); + + if ($PAUSE::Config->{TESTHOST}){ + warn "TESTHOST is NOT sending mail"; + warn "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . + Data::Dumper->new([$header,$blurb],[qw(header blurb)]) + ->Indent(1)->Useqq(1)->Dump; + } + eval { + $self->mailer->send($email); + }; + if (my $error = $@) { + if ($error->isa('Email::Sender::Failure')) { + warn "Sendmail error: $error"; + die PAUSE::Web::Exception->new(ERROR => Mojo::ByteStream->new(<<"ERROR_END")); +Sorry, the PAUSE failed to send an email.
+Administration has been notified. +ERROR_END + } else { + die $error; + } + } + 1; +} + +sub DESTROY { + my $self = shift; + $self->{DbHandle4Authen}->disconnect if ref $self->{DbHandle4Authen}; + $self->{DbHandle}->disconnect if ref $self->{DbHandle}; +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Controller/Admin.pm b/lib/pause_2025/PAUSE/Web/Controller/Admin.pm new file mode 100644 index 000000000..ed601df7b --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Controller/Admin.pm @@ -0,0 +1,202 @@ +package PAUSE::Web::Controller::Admin; + +use Mojo::Base "Mojolicious::Controller"; + +sub email_for_admin { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + + my %ALL; + { + my $dba = $mgr->authen_connect; + my $dbm = $mgr->connect; + my $sth1 = $dbm->prepare(qq{SELECT userid, email + FROM users + WHERE isa_list = '' + AND ( + cpan_mail_alias='publ' + OR + cpan_mail_alias='secr' + )}); + $sth1->execute; + while (my($id,$mail) = $sth1->fetchrow_array) { + $ALL{$id} = $mail; # we store public email even for those who want + # secret, because we never know if we will find a + # secret one + } + $sth1->finish; + my $sth2 = $dbm->prepare(qq{SELECT userid + FROM users + WHERE cpan_mail_alias='secr' + AND isa_list = ''}); + $sth2->execute; + my $sth3 = $dba->prepare(qq{SELECT secretemail + FROM usertable + WHERE user=?}); + while (my($id) = $sth2->fetchrow_array) { + $sth3->execute($id); + next unless $sth3->rows; + my($mail) = $sth3->fetchrow_array or next; + $ALL{$id} = $mail; + } + $sth2->finish; + $sth3->finish; + }; + my $output_format = $req->param("OF"); + if ($output_format){ + if ($output_format eq "YAML") { + return $c->render_yaml(\%ALL); + } else { + die "not supported OF=$output_format" + } + } else { + my @list; + for my $id (sort keys %ALL) { + push @list, {id => $id, mail => $ALL{$id}}; + } + $pause->{list} = \@list; + } +} + +sub edit_ml { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + my $u = $c->active_user_record; + + my $selectedid = ""; + my $selectedrec = {}; + + my $param; + if ($param = $req->param("pause99_edit_ml_3")) { # upper selectbox + $selectedid = $param; + } elsif ($param = $req->param("HIDDENNAME")) { + $selectedid = $param; + $req->param("pause99_edit_ml_3" => $param); + } + + warn sprintf( + "selectedid[%s]IsMR[%s]", + $selectedid, + join(":", + keys(%{$pause->{IsMailinglistRepresentative}}) + ) + ); + + my($sql,@bind); + if (exists $pause->{IsMailinglistRepresentative}{$selectedid}) { + $sql = qq{SELECT users.userid + FROM users JOIN list2user + ON users.userid = list2user.maillistid + WHERE users.isa_list > '' + AND list2user.userid = ? + ORDER BY users.userid +}; + @bind = $pause->{User}{userid}; + } else { + $sql = qq{SELECT userid FROM users WHERE isa_list > '' ORDER BY userid}; + @bind = (); + } + + my $dbh = $mgr->connect; + my $sth = $dbh->prepare($sql); + $sth->execute(@bind); + my @all_mls; + my %mls_lab; + if ($sth->rows) { + my $sth2 = $dbh->prepare(qq{SELECT * FROM maillists WHERE maillistid=?}); + while (my($id) = $mgr->fetchrow($sth, "fetchrow_array")) { + # register this mailinglist for the selectbox + push @all_mls, $id; + # query for more info about it + $sth2->execute($id); + my($rec) = $mgr->fetchrow($sth2, "fetchrow_hashref"); + # we will display the name along the ID + $mls_lab{$id} = "$id ($rec->{maillistname})"; + if ($id eq $selectedid) { + # if this is the selected one, we just store it immediately + $selectedrec = $rec; + } + } + } + $pause->{mls} = [map {[$mls_lab{$_} => $_]} @all_mls]; + + if ($selectedid) { + $pause->{selected} = $selectedrec; + my $force_sel = $req->param('pause99_edit_ml_2'); + my $update_sel = $req->param('pause99_edit_ml_4'); + + $pause->{updated_sel} = $update_sel; + + my $saw_a_change; + my $now = time; + + for my $field (qw(maillistname address subscribe)) { + my $fieldname = "pause99_edit_ml_$field"; + if ($force_sel){ + $req->param($fieldname => $selectedrec->{$field}||""); + } elsif ($update_sel) { + my $param = $req->param($fieldname); + if ($param ne $selectedrec->{$field}) { + my $sql = qq{UPDATE maillists + SET $field=?, + changed=?, + changedby=? + WHERE maillistid=?}; + my $usth = $dbh->prepare($sql); + my $ret = $usth->execute($param, $now, $u->{userid}, $selectedrec->{maillistid}); + $saw_a_change = 1 if $ret > 0; + $usth->finish; + } + } + } + if ($saw_a_change) { + $pause->{changed} = 1; + my $mailblurb = $c->render_to_string("email/admin/edit_ml", format => "email"); + my @to = ($u->{secretemail}||$u->{email}, $mgr->config->mailto_admins); + warn "sending to[@to]"; + warn "mailblurb[$mailblurb]"; + my $header = { + Subject => "Mailinglist update for $selectedrec->{maillistid}" + }; + $mgr->send_mail_multi(\@to, $header, $mailblurb); + } + } +} + +sub select_user { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + + if (my $action = $req->param("ACTIONREQ")) { + if ( + $mgr->config->has_action($action) + ) { + $req->param("ACTION" => $action); + $pause->{Action} = $action; + return $c->delegate($action); + } else { + die "cannot action[$action]"; + } + } + + my %user_meta = $c->user_meta; + my $labels = $user_meta{userid}{args}{labels}; + $pause->{hidden_name_list} = [map {[ + $labels->{$_} => $_, + ($_ eq $pause->{User}{userid} ? (selected => "selected") : ()), + ]} sort keys %$labels]; + + my $action_map = $mgr->config->action_map_to_verb($mgr->config->allow_admin_takeover); + $pause->{action_req_list} = [map {[ + $action_map->{$_} => $_, + ($_ eq 'edit_cred' ? (selected => "selected") : ()), + ]} sort keys %$action_map]; +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Controller/Admin/ManageId.pm b/lib/pause_2025/PAUSE/Web/Controller/Admin/ManageId.pm new file mode 100644 index 000000000..6fd2f120d --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Controller/Admin/ManageId.pm @@ -0,0 +1,66 @@ +package PAUSE::Web::Controller::Admin::ManageId; + +use Mojo::Base "Mojolicious::Controller"; +use Storable; +use File::Find; +use JSON::XS; # used in the template + +sub manage { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + + return unless exists $pause->{UserGroups}{admin}; + + return unless -d $c->session_data_dir; + + my %ALL; + my $delete; + if ($req->param("subaction") && $req->param("subaction") eq "delete") { + $delete = $req->param("USERID"); + } + my $dbh = $mgr->connect; + my $sthu = $dbh->prepare("SELECT userid from users where userid=?"); + + find + ( + {wanted => sub { + my $path = $_; + my @stat = stat $path or die "Could not stat '$path': $!"; + return unless -f _; + my $mtime = $stat[9]; + open my $fh, "<", $path or die "Couldn't open '$path': $!"; + local $/; + my $content = <$fh>; + my $session = Storable::thaw $content; + # warn "DEBUG: mtime[$mtime]stat[@stat]session[$session]"; + my $userid = $session->{APPLY}{userid} or return; + if ($delete && $session->{_session_id} eq $delete) { + unlink $path or die "Could not unlink '$path': $!"; + return; + } + my $type; + if (exists $session->{APPLY}{fullname}) { + $sthu->execute($userid); + return if $sthu->rows > 0; + $type = "user"; + } + if ($session->{APPLY}{rationale} =~ /\b(?:BLONDE\s+NAKED|NAKED\s+SEXY|FREE\s+CUMSHOT|CUMSHOT\s+VIDEOS|FREE\s+SEX|FREE\s+TUBE|GROUP\s+SEX|FREE\s+PORN|SEX\s+VIDEO|SEX\s+MOVIES?|SEX\s+TUBE|SEX\s+MATURE|STREET\s+BLOWJOBS|SEX\s+PUBLIC|TUBE\s+PORN|PORN\s+TUBE|TUBE\s+VIDEOS|VIDEO\s+TUBE|XNXX\s+VIDEOS|XXX\s+FREE|ANIMAL\s+SEX|GIRLS\s+SEX|PORN\s+VIDEOS?|PORN\s+MOVIES|TITS\s+PORN|RAW\s+SEX|DEEPTHROAT\s+TUBE|celeb\s+porn|PREGNANT\s+TUBE|picture\s+sex|NAKED\s+WOMEN|WOMEN\s+MOVIES|MATURE\s+NAKED|SEX\s+ANIME|hot\s+nude|nude\s+celebs|ANIME\s+TUBES|SEX\s+DOG|MATURE\s+SEX|MATURE\s+PUSSY|Rape\s+Porn|brutal\s+fuck|rape\s+video|ANIMAL\s+TUBE|SHEMALE\s+CUMSHOT|ANIMAL\s+PORN|ANIMAP\s+CLIP|CLIP\s+SEX|PUBLIC\s+BLOWJOB|free\s+lesbian|lesbian\s+sex|SEX\s+ZOO|tv-adult|numismata.org|www.soulcommune.com|www.petsusa.org|www.csucssa.org|www.thisis50.com|www.comunidad-latina.net|www.singlefathernetwork.com|www.freetoadvertise.biz|gayforum.dk|www.purevolume.com|playgroup.themouthpiece.com|www.bananacorp.cl|party.thebamboozle.com|blog.tellurideskiresort.com|www.pethealthforums.com|www.burropride.com|lpokemon.19.forumer.com|Zootube365|Eskimotube|xtube-1|phentermine without a prescription)\b/i) { + unlink $path or die "Could not unlink '$path': $!"; + return; + } + $ALL{$path} = { + session => $session, + mtime => $mtime, + type => $type, + }; + }, + no_chdir => 1, + }, + $c->session_data_dir, + ); + $pause->{all} = \%ALL; +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Controller/Admin/User.pm b/lib/pause_2025/PAUSE/Web/Controller/Admin/User.pm new file mode 100644 index 000000000..8f542932a --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Controller/Admin/User.pm @@ -0,0 +1,307 @@ +package PAUSE::Web::Controller::Admin::User; + +use Mojo::Base "Mojolicious::Controller"; +use PAUSE::Web::Util::Encode; +use Text::Soundex; +use Text::Metaphone; +use Text::Format; + +sub add { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + my $dbh = $mgr->connect; + local($dbh->{RaiseError}) = 0; + + if ($req->param("USERID")) { + my $session = $c->new_session_counted; + my $s = $session->{APPLY}; + for my $a (keys %$s) { + $req->param("pause99_add_user_$a" => $s->{$a}); + warn "retrieving from session a[$a]s(a)[$s->{$a}]"; + } + } + + my $userid; + if ( $userid = $req->param("pause99_add_user_userid") ) { + + $userid = uc($userid); + $userid ||= ""; + $pause->{userid} = $userid; + + my @error; + if ( $userid !~ $mgr->config->valid_userid ) { + push @error, {invalid => 1}; + } + + $req->param("pause99_add_user_userid" => $userid) if $userid; + + my $doit = 0; + my $fullname_raw = $req->param('pause99_add_user_fullname') // ''; + my($fullname); + $fullname = PAUSE::Web::Util::Encode::any2utf8($fullname_raw); + warn "fullname[$fullname]fullname_raw[$fullname_raw]"; + if ($fullname ne $fullname_raw) { + $req->param("pause99_add_user_fullname" => $fullname); + my $debug = $req->param("pause99_add_user_fullname"); + warn "debug[$debug]fullname[$fullname]"; + } + unless ($fullname) { + warn "no fullname"; + push @error, {no_fullname => 1}; + } + $pause->{fullname} = $fullname; + + unless (@error) { + if ($req->param('SUBMIT_pause99_add_user_Definitely')) { + $doit = 1; + } elsif ( + $req->param('SUBMIT_pause99_add_user_Soundex') + || + $req->param('SUBMIT_pause99_add_user_Metaphone') + ) { + + # START OF SOUNDEX/METAPHONE check + + my ($surname); + my($s_package) = $req->param('SUBMIT_pause99_add_user_Soundex') ? + 'Text::Soundex' : 'Text::Metaphone'; + + ($surname = $fullname) =~ s/.*\s//; + my $query = qq{SELECT userid, fullname, email, homepage, + introduced, changedby, changed + FROM users + WHERE isa_list='' + }; + my $sth = $dbh->prepare($query); + $sth->execute; + my $s_func; + if ($s_package eq "Text::Soundex") { + $s_func = \&Text::Soundex::soundex; + } elsif ($s_package eq "Text::Metaphone") { + $s_func = \&Text::Metaphone::Metaphone; + } + my $s_code = $s_func->($surname); + $pause->{s_package} = $s_package; + $pause->{s_code} = $s_code; + + warn "s_code[$s_code]"; + my $requserid = $req->param("pause99_add_user_userid")||""; + my $reqfullname = $req->param("pause99_add_user_fullname")||""; + my $reqemail = $req->param("pause99_add_user_email")||""; + my $reqhomepage = $req->param("pause99_add_user_homepage")||""; + my($suserid,$sfullname, $spublic_email, $shomepage, + $sintroduced, $schangedby, $schanged); + # if a user has a preference to display secret emails in a + # certain color, they can enter it here: + my %se_color_map = ( + jv => "black", + andk => "#f33", + ); + my $se_color = $se_color_map{lc $pause->{User}{userid}} || "red"; + $pause->{se_color} = $se_color; + + my @urows; + while (($suserid, $sfullname, $spublic_email, $shomepage, + $sintroduced, $schangedby, $schanged) = + $mgr->fetchrow($sth, "fetchrow_array")) { + (my $dbsurname = $sfullname) =~ s/.*\s//; + next unless $s_func->($dbsurname) eq $s_code; + my %urow; + my $score = 0; + my $ssecretemail = $c->get_secretemail($suserid); + + if (defined($suserid)&&length($suserid)) { + if ($requserid eq $suserid) { + $urow{same_userid} = 1; + $score++; + } + $urow{userid} = $suserid; + } + { + if ($sfullname eq $reqfullname) { + $urow{same_fullname} = 1; + $score++; + } elsif ($sfullname =~ /\Q$surname\E/) { + $urow{surname} = $surname; + my ($before, $after) = split /\Q$surname\E/, $sfullname, 2; + $urow{before_surname} = $before // ""; + $urow{after_surname} = $after // ""; + $score++; + } + if (defined($sfullname)&&length($sfullname)) { + $urow{fullname} = $sfullname; + } + } + my @email_parts = split '@', $spublic_email; + { + if ($spublic_email eq $reqemail) { + $urow{same_email} = 1; + $score++; + } + $urow{email_parts} = \@email_parts; + } + if ($ssecretemail) { + $urow{secretemail} = $ssecretemail; + + if ($ssecretemail eq $reqemail) { + $urow{same_secretemail} = 1; + $score++; + } + } + if ($shomepage) { + if ($shomepage eq $reqhomepage) { + $urow{same_homepage} = 1; + $score++; + } + $urow{homepage} = $shomepage; + } + if ($sintroduced) { + $urow{introduced} = scalar(gmtime($sintroduced)); + } + if ($schanged) { + $urow{changed} = scalar(gmtime($schanged)); + } + $urow{changedby} = $schangedby; + push @urows, { + line => \%urow, + score => $score, + }; + } + if (@urows) { + $doit = 0; + $pause->{urows} = \@urows; + } else { + $doit = 1; + } + + # END OF SOUNDEX/METAPHONE check + } + } + $pause->{doit} = $doit; + + if ($doit) { + $c->add_user_doit($userid,$fullname); + } elsif (@error) { + $pause->{error} = \@error; + } else { + my $T = time; + warn "T[$T]doit[$doit]userid[$userid]"; + } + } else { + warn "No userid, nothing done"; + } +} + +sub get_secretemail { + my ($c, $userid) = @_; + my $mgr = $c->app->pause; + my $dbh2 = $mgr->authen_connect; + my $sth2 = $dbh2->prepare("SELECT secretemail + FROM $PAUSE::Config->{AUTHEN_USER_TABLE} + WHERE $PAUSE::Config->{AUTHEN_USER_FLD}=?"); + $sth2->execute($userid); + my($h2) = $mgr->fetchrow($sth2, "fetchrow_array"); + $sth2->finish; + $h2; +} + +sub add_user_doit { + my($c, $userid, $fullname) = @_; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + my $T = time; + my $dbh = $mgr->connect; + local($dbh->{RaiseError}) = 0; + + my($query,$sth,@qbind); + my($email) = $req->param('pause99_add_user_email'); + my($homepage) = $req->param('pause99_add_user_homepage'); + my $subscribe = $req->param('pause99_add_user_subscribe') // ''; + my $entered_by = $pause->{User}{fullname} || $pause->{User}{userid}; + my $is_mailing_list = $subscribe gt ''; + if ( $is_mailing_list ) { + $query = qq{INSERT INTO users ( + userid, isa_list, introduced, + changed, changedby) + VALUES ( + ?, ?, ?, + ?, ?)}; + @qbind = ($userid,1,$T,$T,$pause->{User}{userid}); + } else { + $query = qq{INSERT INTO users ( + userid, email, homepage, fullname, + isa_list, introduced, changed, changedby) + VALUES ( + ?, ?, ?, ?, + ?, ?, ?, ?)}; + @qbind = ($userid,"CENSORED",$homepage,$fullname,"",$T,$T,$pause->{User}{userid}); + } + + # We have a query for INSERT INTO users + + if ($dbh->do($query,undef,@qbind)) { + $pause->{succeeded} = 1; + + if ( $is_mailing_list ) { + # Add a mailinglist: INSERT INTO maillists + + my($maillistid) = $userid; + my($maillistname) = $fullname; + my($changed) = $T; + $pause->{maillistname} = $maillistname; + $pause->{subscribe} = $subscribe; + + $query = qq{INSERT INTO maillists ( + maillistid, maillistname, + subscribe, changed, changedby, address) + VALUES ( + ?, ?, + ?, ?, ?, ?)}; + my @qbind2 = ($maillistid, $maillistname, + $subscribe, $changed, $pause->{User}{userid}, $email); + unless ($dbh->do($query,undef,@qbind2)) { + die PAUSE::Web::Exception + ->new(ERROR => [qq{Query[$query]with qbind2[@qbind2] failed. Reason:}, $DBI::errstr]); + } + + } else { + # Not a mailinglist: set and send one time password + my $onetime = $c->set_onetime_password($userid, $email); + $c->send_otp_email($userid, $email, $onetime); + # send emails to user and modules@perl.org; latter must censor the + # user's email address + my ($subject, $blurb) = $c->send_welcome_email( [$email], $userid, $email, $fullname, $homepage, $entered_by ); + $c->send_welcome_email( $PAUSE::Config->{ADMINS}, $userid, "CENSORED", $fullname, $homepage, $entered_by ); + + $pause->{subject} = $subject; + $pause->{blurb} = $blurb; + $pause->{send_to} = join(" AND ", @{$PAUSE::Config->{ADMINS}}, $email); + } + + warn "Info: clearing all fields"; + for my $field (qw(userid fullname email homepage subscribe)) { + my $param = "pause99_add_user_$field"; + $req->param($param => ""); + } + + } else { + $pause->{query} = $query; + $pause->{query_error} = $dbh->errstr; + } + + # usertable { + { + my $sql = "SELECT * FROM users WHERE userid=?"; + my $sth = $dbh->prepare($sql); + $sth->execute($userid); + return unless $sth->rows == 1; + my $rec = $mgr->fetchrow($sth, "fetchrow_hashref"); + + $pause->{usertable} = $rec; + } +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Controller/Mlrepr.pm b/lib/pause_2025/PAUSE/Web/Controller/Mlrepr.pm new file mode 100644 index 000000000..3d71bb403 --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Controller/Mlrepr.pm @@ -0,0 +1,78 @@ +package PAUSE::Web::Controller::Mlrepr; + +use Mojo::Base "Mojolicious::Controller"; + +sub select_ml_action { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + + my $dbh = $mgr->connect; + if (my $action = $req->param("ACTIONREQ")) { + if ( + $mgr->config->has_action($action) + && + grep { $_ eq $action } $mgr->config->allow_mlrepr_takeover + ) { + $req->param(ACTION => $action); + $pause->{Action} = $action; + return $c->delegate($action); + } else { + die "cannot or want not action[$action]"; + } + } + + my ($sql, @bind); + if (exists $pause->{UserGroups}{admin}) { + $sql = qq{SELECT users.userid + FROM users, list2user + WHERE isa_list > '' + AND users.userid = list2user.maillistid + ORDER BY users.userid + }; + } else { + $sql = qq{SELECT users.userid + FROM users, list2user + WHERE isa_list > '' + AND users.userid = list2user.maillistid + AND list2user.userid = ? + ORDER BY users.userid + }; + @bind = $pause->{User}{userid}; + } + + my $sth = $dbh->prepare($sql); + $sth->execute(@bind); + my %u; + while (my @row = $mgr->fetchrow($sth, "fetchrow_array")) { + $u{$row[0]} = $row[0]; + } + + my $action_map = $mgr->config->action_map_to_verb($mgr->config->allow_mlrepr_takeover); + my @action_reqs = map {[$action_map->{$_} => $_]} sort keys %$action_map; + $pause->{users} = [sort {lc($u{$a}) cmp lc($u{$b})} keys %u]; + $pause->{action_reqs} = \@action_reqs; +} + +sub show_ml_repr { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + + my $dbh = $mgr->connect; + my $sth = $dbh->prepare("SELECT maillistid, userid + FROM list2user + ORDER BY maillistid, userid"); + $sth->execute; + + my @lists; + while (my $rec = $mgr->fetchrow($sth, "fetchrow_hashref")) { + push @lists, $rec; + } + $sth->finish; + + $pause->{lists} = \@lists; +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Controller/Public.pm b/lib/pause_2025/PAUSE/Web/Controller/Public.pm new file mode 100644 index 000000000..46ae90bb2 --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Controller/Public.pm @@ -0,0 +1,223 @@ +package PAUSE::Web::Controller::Public; + +use Mojo::Base "Mojolicious::Controller"; +use Time::Duration; + +sub mailpw { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + my ($param, $email); + + # TUT: We reach this point in the code only if the Querystring + # specified ACTION=mailpw or something equivalent. The parameter ABRA + # is used to denote the token that we might have sent them. + my $abra = $req->param("ABRA") || ""; + + # TUT: The parameter pause99_mailpw_1 denotes the userid of the user + # for whom a password change was requested. Note that anybody has + # access to that parameter, we do not authentify its origin. Of + # course not, because that guy says he has lost the password:-) If + # this parameter is there, we are asked to send a token. Otherwise + # they only want to see the password-requesting form. + $param = $req->param("pause99_mailpw_1"); + if ( uc $req->method eq 'POST' and $param ) { + $param = uc($param); + unless ($param =~ /^[A-Z\-]+$/) { + if ($param =~ /@/) { + die PAUSE::Web::Exception->new(ERROR => + qq{Please supply a userid, not an email address.}); + } + die PAUSE::Web::Exception->new(ERROR => + qq{A userid of $param is not allowed, please retry with a valid userid. Nothing done.}); # FIXME + } + $pause->{mailpw_userid} = $param; + + # TUT: The object $mgr is our knows/is/can-everything object. Here + # it connects us to the authenticating database + my $authen_dbh = $mgr->authen_connect; + my $sql = qq{SELECT * + FROM usertable + WHERE user = ? }; + my $sth = $authen_dbh->prepare($sql); + $sth->execute($param); + my $rec = {}; + if ($sth->rows == 1) { + $rec = $mgr->fetchrow($sth, "fetchrow_hashref"); + } else { + my $u; + eval { + $u = $c->active_user_record($param); + }; + if ($@) { + # FIXME + die PAUSE::Web::Exception->new(ERROR => + qq{Cannot find a userid + of $param, please + retry with a valid + userid.}); + } elsif ($u->{userid} && $u->{email}) { + # this is one of the 94 users (counted on 2005-01-05) that has + # a users record but no usertable record + $sql = qq{INSERT INTO usertable (user,secretemail,forcechange,changed) + VALUES (?, ?, 1, ?)}; + + $authen_dbh->do($sql,{},$u->{userid},$u->{email},time) + or die PAUSE::Web::Exception->new(ERROR => + qq{The userid of $param + is too old for this interface. Please get in touch with administration.}); # FIXME + + $rec->{secretemail} = $u->{email}; + } else { + die PAUSE::Web::Exception->new(ERROR => + qq{A userid of $param + is not known, please retry with a valid userid.}); # FIXME + } + } + + # TUT: all users may have a secret and a public email. We pick what + # we have. + unless ($email = $rec->{secretemail}) { + my $u = $c->active_user_record($param,{hidden_user_ok => 1}); + require YAML::Syck; + my $message = "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . YAML::Syck::Dump({u=>$u}); + $mgr->log({level => 'debug', message => $message}); + $email = $u->{email}; + } + if ($email) { + $pause->{valid_email} = 1; + + # TUT: Before we insert a record from that table, we remove old + # entries so the primary key of an old record doesn't block us now. + $sql = sprintf qq{DELETE FROM abrakadabra + WHERE NOW() > expires}; + $authen_dbh->do($sql); + + my $passwd = sprintf "%08x" x 4, rand(0xffffffff), rand(0xffffffff), + rand(0xffffffff), rand(0xffffffff); + # warn "pw[$passwd]"; + $pause->{passwd} = $passwd; + + my $then = time + $PAUSE::Config->{ABRA_EXPIRATION}; + $sql = qq{INSERT INTO abrakadabra + ( user, chpasswd, expires ) + VALUES + ( ?, ?, from_unixtime(?) ) }; + local($authen_dbh->{RaiseError}) = 0; + if ( $authen_dbh->do($sql,undef,$param,$passwd,$then) ) { + } elsif ($authen_dbh->errstr =~ /Duplicate entry/) { + my $duration; + $duration = Time::Duration::duration($PAUSE::Config->{ABRA_EXPIRATION}); + die PAUSE::Web::Exception->new + ( + ERROR => qq{A token for $param that allows + changing of the password has been requested recently + (less than $duration ago) and is still valid. Nothing + done.} + ); + } else { + die PAUSE::Web::Exception->new(ERROR => $authen_dbh->errstr); + } + + # between Apache::URI and URI::URL + my $me = $c->my_full_url; # FIXME + $me =~ s/^http:/https:/; # do not blindly inherit the schema + + my $mailblurb = $c->render_to_string("email/public/mailpw", format => "email"); + + my $header = { Subject => "Your visit at $me" }; + warn "mailto[$email]mailblurb[$mailblurb]"; + $mgr->send_mail_multi([$email], $header, "$mailblurb"); + } + } +} + +sub about { + my $c = shift; + $c->serve_pause_doc("04pause.html", "needs_rewrite") +} + +sub naming { + my $c = shift; + $c->serve_pause_doc("namingmodules.html") +} + +sub news { + my $c = shift; + $c->serve_pause_doc("index.html") +} + +sub history { + my $c = shift; + $c->serve_pause_doc("history.html") +} + +sub imprint { + my $c = shift; + $c->serve_pause_doc("imprint.html") +} + +sub operating_model { + my $c = shift; + $c->serve_pause_doc("doc/operating-model.md") +} + +sub privacy_policy { + my $c = shift; + $c->serve_pause_doc("doc/privacy-policy.md") +} + +sub pumpkin { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + + my @hres; + { + my $dbh = $mgr->authen_connect; + my $sth = $dbh->prepare("SELECT user FROM grouptable WHERE ugroup='pumpking' order by user"); + $sth->execute; + while (my @row = $sth->fetchrow_array) { + push @hres, $row[0]; + } + $sth->finish; + }; + + if (my $output_format = $c->req->param("OF")) { + if ($output_format eq "YAML") { + return $c->render_yaml(\@hres); + } else { + die "not supported OF=$output_format" + } + } + $pause->{pumpkins} = \@hres; +} + +sub admin { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + + my @hres; + { + my $dbh = $mgr->authen_connect; + my $sth = $dbh->prepare("SELECT user FROM grouptable WHERE ugroup='admin' order by user"); + $sth->execute; + while (my @row = $sth->fetchrow_array) { + push @hres, $row[0]; + } + $sth->finish; + }; + my $output_format = $c->req->param("OF"); + if ($output_format){ + if ($output_format eq "YAML") { + return $c->render_yaml(\@hres); + } else { + die "not supported OF=$output_format" + } + } + $pause->{admins} = \@hres; +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Controller/Public/RequestId.pm b/lib/pause_2025/PAUSE/Web/Controller/Public/RequestId.pm new file mode 100644 index 000000000..5ea014ceb --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Controller/Public/RequestId.pm @@ -0,0 +1,269 @@ +package PAUSE::Web::Controller::Public::RequestId; + +use Mojo::Base "Mojolicious::Controller"; +use PAUSE::Web::Util::Encode; +use Email::Address; + +sub request { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + my $valid_userid = $mgr->config->valid_userid; + + # first time: form + # second time with error: error message + form + # second time without error: OK message + # bot debunked? => "Thank you!" + + my $showform = 0; + my $regOK = 0; + + if ($req->param('url')) { # debunked + $c->stash(format => 'text'); + $c->render(text => "Thank you!"); + return; + } + + my $fullname = $req->param('pause99_request_id_fullname') || ""; + my $ufullname = PAUSE::Web::Util::Encode::any2utf8($fullname); + if ($ufullname ne $fullname) { + $req->param("pause99_request_id_fullname" => $ufullname); + $fullname = $ufullname; + } + my $email = $req->param('pause99_request_id_email') || ""; + my $homepage = $req->param('pause99_request_id_homepage') || ""; + my $userid = $req->param('pause99_request_id_userid') || ""; + my $rationale = $req->param("pause99_request_id_rationale") || ""; + my $token = $req->param("g-recaptcha-response") || ""; + my $urat = PAUSE::Web::Util::Encode::any2utf8($rationale); + if ($urat ne $rationale) { + $req->param("pause99_request_id_rationale" => $urat); + $rationale = $urat; + } + warn sprintf( + "userid[%s]Valid_Userid[%s]args[%s]", + $userid, + $valid_userid, + scalar($req->url->query)||"", + ); + + if ( $req->param("SUBMIT_pause99_request_id_sub") ) { + # check for errors + + my @errors = (); + if ( $fullname ) { + unless ($fullname =~ /[ ]/) { + push @errors, "Name does not look like a full civil name. Please accept our apologies if you believe we're wrong. In this case please write to @{$PAUSE::Config->{ADMINS}}."; + } + } else { + push @errors, "You must supply a name\n"; + } + if( $email ) { + my $addr_spec = $Email::Address::addr_spec; + push @errors, "Your email address doesn't look like valid email address.\n" unless $email =~ /\A$addr_spec\z/; + } else { + push @errors, "You must supply an email address\n"; + } + if ( $rationale ) { + + $rationale =~ s/^\s+//; + $rationale =~ s/\s+$//; + $rationale =~ s/\s+/ /; + push @errors, "Thank you for giving us a short description of + what you're planning to contribute, but frankly, this looks a + bit too short" if length($rationale)<10; + push @errors, "Please do not use HTML links in your description of + what you're planning to contribute" if $rationale =~ /<\s*a\s+href\s*=/ims; + + my $url_count =()= $rationale =~ m{https?://}gi; + push @errors, "Please do not include more than one URL in your description of + what you're planning to contribute" if $url_count > 1; + + } else { + + push @errors, "You must supply a short description of what + you're planning to contribute\n"; + + } + if ( $userid ) { + $userid = uc $userid; + $req->param('pause99_request_id_userid' => $userid); + my $db = $mgr->connect; + my $sth = $db->prepare("SELECT userid FROM users WHERE userid=?"); + $sth->execute($userid); + warn sprintf("userid[%s]Valid_Userid[%s]matches[%s]", + $userid, + $valid_userid, + $userid =~ $valid_userid || "", + ); + if ($sth->rows > 0) { + push @errors, "The userid $userid is already taken."; + } elsif ($userid !~ $valid_userid) { + push @errors, "The userid $userid does not match $valid_userid."; + } + $sth->finish; + } else { + push @errors, "You must supply a desired user-ID\n"; + } + if ( $PAUSE::Config->{RECAPTCHA_ENABLED} && ! $token ) { + push @errors, "You must complete the recaptcha to proceed\n"; + } + if( @errors ) { + $pause->{errors} = \@errors; + $showform = 1; + } else { + $regOK = 1; + } + } else { + $showform = 1; + } + $pause->{showform} = $showform; + $pause->{reg_ok} = $regOK; + + if ($regOK) { + if ( $PAUSE::Config->{RECAPTCHA_ENABLED} ) { + if ( $c->auto_registration_rate_limit_ok ) { + $pause->{recaptcha_enabled} = 1; + my ($valid, $err) = $c->verify_recaptcha($token); + if ( $valid ) { + # If recaptcha is valid, we shortcut and add the user directly, + # returning HTML for them to see. + return $c->_directly_add_user($userid, $fullname); + } + elsif ( defined $valid && ! $valid ) { + die PAUSE::Web::Exception->new(ERROR => "recaptcha failed validation: $err\n"); + } + # else recapture couldn't complete so continue with normal + # ID request moderation + } else { + warn "reCAPTCHA rate limit is exceeded"; + } + } + + my @to = $mgr->config->mailto_admins; + push @to, $email; + $pause->{send_to} = "@to"; + my $time = time; + if ($rationale) { + # wrap it + $rationale =~ s/\r\n/\n/g; + $rationale =~ s/\r/\n/g; + my @rat = split /\n\n/, $rationale; + my $tf = Text::Format->new( bodyIndent => 4, firstIndent => 5); + $rationale = $tf->paragraphs(@rat); + $rationale =~ s/^\s{5}/\n /gm; + } + + my $session = $c->new_session_counted; + $session->{APPLY} = { + fullname => $fullname, + email => $email, + homepage => $homepage, + userid => $userid, + rationale => $rationale, + }; + require Data::Dumper; + my $message = "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([$session->{APPLY}],[qw(APPLY)])->Indent(1)->Useqq(1)->Dump; + $c->app->pause->log({level => 'debug', message => $message }); + if (lc($fullname) eq lc($userid)) { + die PAUSE::Web::Exception->new(ERROR => "fullname looks like spam"); + } + if (my @x = $rationale =~ /(\.info)/g) { + die PAUSE::Web::Exception->new(ERROR => "rationale looks like spam") if @x >= 5; + } + if (my @x = $rationale =~ m|(http://)|g) { + die PAUSE::Web::Exception->new(ERROR => "rationale looks like spam") if @x >= 5; + } + if ($rationale =~ /interesting/i && $homepage =~ m|http://[^/]+\.cn/.+\.htm$|) { + die PAUSE::Web::Exception->new(ERROR => "rationale looks like spam"); + } + + $pause->{fullname} = $fullname; + $pause->{userid} = $userid; + $pause->{homepage} = $homepage; + $pause->{rationale} = $rationale; + + $pause->{session_id} = $c->session_counted_userid; + my $subject = "PAUSE ID request ($userid; $fullname)"; + my $header = { + To => $email, + Subject => $subject, + }; + my $blurb = $c->render_to_string("email/public/request_id", format => "email"); + + require HTML::Entities; + my($blurbcopy) = HTML::Entities::encode($blurb,qq{<>&"}); + $blurbcopy =~ s{( + https?:// + [^"'<>\s]+ # arbitrary exclusions, we had \S there, + # but it broke too often + ) + }{$1}xg; + $blurbcopy =~ s|(>http.*?)U|$1\n U|gs; # break the long URL + + $pause->{subject} = $subject; + $pause->{blurbcopy} = $blurbcopy; + + $header = { + Subject => $subject + }; + warn "To[@to]Subject[$header->{Subject}]"; + $mgr->send_mail_multi(\@to,$header,$blurb); + } +} + +sub _directly_add_user { + my ($c, $userid, $fullname) = @_; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + + my $T = time; + my $dbh = $mgr->connect; + local ( $dbh->{RaiseError} ) = 0; + + my ( $query, $sth, @qbind ); + my ($email) = $req->param('pause99_request_id_email'); + my ($homepage) = $req->param('pause99_request_id_homepage'); + $query = qq{INSERT INTO users ( + userid, email, homepage, fullname, + isa_list, introduced, changed, changedby) + VALUES ( + ?, ?, ?, ?, + ?, ?, ?, ?)}; + @qbind = + ( $userid, "CENSORED", $homepage, $fullname, "", $T, $T, 'RECAPTCHA' ); + + # We have a query for INSERT INTO users + + if ( $dbh->do( $query, undef, @qbind ) ) { + $pause->{added_user} = 1; + # Not a mailinglist: set and send one time password + my $onetime = $c->set_onetime_password( $userid, $email ); + $c->send_otp_email( $userid, $email, $onetime ); + + # send emails to user and modules@perl.org; latter must censor the + # user's email address + my ( $subject, $blurb ) = + $c->send_welcome_email( [$email], $userid, $email, $fullname, $homepage, + $fullname ); + $c->send_welcome_email( $PAUSE::Config->{ADMINS}, + $userid, "CENSORED", $fullname, $homepage, $fullname ); + + $pause->{subject_for_user_addition} = $subject; + $pause->{blurb_for_user_addition} = $blurb; + + warn "Info: clearing all fields"; + for my $field (qw(userid fullname email homepage subscribe)) { + my $param = "pause99_request_id_$field"; + $req->param( $param, "" ); + } + } + else { + warn qq{New user creation failed: [$query] failed. Reason: } . $dbh->errstr; + # TODO should notify administrators if this occurs + } +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Controller/Root.pm b/lib/pause_2025/PAUSE/Web/Controller/Root.pm new file mode 100644 index 000000000..c2e2397fc --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Controller/Root.pm @@ -0,0 +1,50 @@ +package PAUSE::Web::Controller::Root; + +use Mojo::Base "Mojolicious::Controller"; + +sub check { + my $c = shift; + + if ($c->pause_is_closed) { + my $user = $c->req->env->{REMOTE_USER}; + if ($user and $user eq "ANDK") { + } else { + $c->render("closed"); + return; + } + } + + return 1; +} + +sub index { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + + return unless exists $pause->{User}; + my $u = $c->active_user_record; + + # Special case for cpan-uploaders that post to the /pause/authenquery without any ACTION + return unless $u->{userid}; + return unless uc $req->method eq 'POST'; + return unless $req->param('SUBMIT_pause99_add_uri_HTTPUPLOAD') || $req->param('SUBMIT_pause99_add_uri_httpupload'); + + my $action = 'add_uri'; + $req->param('ACTION' => $action); + $pause->{Action} = $action; + + # kind of delegate but don't add action to stack + my $routes = $c->app->routes; + my $route = $routes->lookup($action) or die "no route for $action"; + my $to = $route->to; + $routes->_controller($c, $to); +} + +sub auth { + my $c = shift; + return 1; +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Controller/User.pm b/lib/pause_2025/PAUSE/Web/Controller/User.pm new file mode 100644 index 000000000..d15ffede7 --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Controller/User.pm @@ -0,0 +1,420 @@ +package PAUSE::Web::Controller::User; + +use Mojo::Base "Mojolicious::Controller"; +use File::pushd; +use PAUSE (); +use Set::Crontab; + +sub edit_uris { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + + my $selectedid = ""; + my $selectedrec = {}; + if (my $param = $req->param("pause99_edit_uris_3")) { # upper selectbox + $selectedid = $param; + } + my $u = $c->active_user_record; + + my $dbh = $mgr->connect; + my $sql = qq{SELECT uriid + FROM uris + WHERE dgot='' + AND userid=? + ORDER BY uriid}; + my $sth = $dbh->prepare($sql); + $sth->execute($u->{userid}); + + my @all_recs; + my %labels; + if (my $rows = $sth->rows) { + my $sth2 = $dbh->prepare(qq{SELECT * + FROM uris + WHERE dgot='' + AND dverified='' + AND uriid=? + AND userid=?}); + while (my($id) = $mgr->fetchrow($sth, "fetchrow_array")) { + # register this mailinglist for the selectbox + push @all_recs, $id; + # query for more info about it + $sth2->execute($id,$u->{userid}); # really needed only for the + # record we want to edit, but + # maybe also needed for a + # label in the selectbox + my($rec) = $mgr->fetchrow($sth2, "fetchrow_hashref"); + # we will display the name along the ID + # $labels{$id} = "$id ($rec->{userid})"; + $labels{$id} = $id; # redundant, but flexible + if ($rows == 1 || $id eq $selectedid) { + # if this is the selected one, we just store it immediately + $selectedid = $id; + $selectedrec = $rec; + } + } + } else { + $pause->{no_pending_uploads} = 1; + return; + } + + $pause->{all_recs} = [map {[$labels{$_} => $_]} @all_recs]; + $pause->{selected} = $selectedrec; + + if ($selectedid) { + my @m_rec; + my $force_sel = $req->param('pause99_edit_uris_2'); + my $update_sel = $req->param('pause99_edit_uris_4'); + $pause->{update_sel} = $update_sel; + + my $saw_a_change; + my $now = time; + + for my $field (qw( + uri + nosuccesstime + nosuccesscount + changed + changedby + )) { + my $fieldname = "pause99_edit_uris_$field"; + if ($force_sel) { + $req->param($fieldname, $selectedrec->{$field}||""); + } elsif ($update_sel && $field eq "uri") { + my $param = $req->param($fieldname); + if ($param ne $selectedrec->{$field}) { + # no, we do not double check for user here. What if they + # change the owner? And we do not prepare outside the loop + # because the is a $fields in there + my $sql = qq{UPDATE uris + SET $field=?, + changed=?, + changedby=? + WHERE uriid=?}; + + my $usth = $dbh->prepare($sql); + my $ret = $usth->execute($param, + $now, + $u->{userid}, + $selectedrec->{uriid}); + + $saw_a_change = 1 if $ret > 0; + $usth->finish; + } + } + } + + if ($saw_a_change) { + $pause->{changed} = 1; + + my $mailbody = $c->render_to_string("email/user/edit_uris", format => "email"); + my @to = $mgr->prepare_sendto($u, $pause->{User}, $mgr->config->mailto_admins); + my $header = { + Subject => "Uri update for $selectedrec->{uriid}" + }; + $mgr->send_mail_multi(\@to,$header,$mailbody); + } + } +} + +sub reindex { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + + my $u = $c->active_user_record; + my $dbh = $mgr->connect; + local($dbh->{RaiseError}) = 0; + my $userhome = PAUSE::user2dir($u->{userid}); + $pause->{userhome} = $userhome; + + my $pushd = eval { pushd("$PAUSE::Config->{MLROOT}/$userhome") } or return; + + my $blurb = ""; + my $server = $PAUSE::Config->{SERVER_NAME} || $req->url->to_abs->host; + if ($req->param('SUBMIT_pause99_reindex_delete')) { + + my $sql = "DELETE FROM distmtimes + WHERE dist = ?"; + my $sth = $dbh->prepare($sql); + foreach my $f (@{$req->every_param('pause99_reindex_FILE')}) { + if ($f =~ m,^/, || $f =~ m,/\.\./,) { + $blurb .= "WARNING: illegal filename: $userhome/$f\n"; + next; + } + unless (-f $f){ + $blurb .= "WARNING: file not found: $userhome/$f\n"; + next; + } + if ($f =~ m{ (^|/) CHECKSUMS }x) { + $blurb .= "WARNING: indexing CHECKSUMS considered unnecessary: $userhome/$f\n"; + next; + } + # delete from distmtimes where distmtimes.dist like '%SREZIC%Tk-DateE%'; + my $ret = $sth->execute("$userhome/$f"); + if ($ret > 0) { + $blurb .= "\$CPAN/authors/id/$userhome/$f\n"; + } else { + $blurb .= "WARNING: $userhome/$f has never been indexed.\n" + . "(Maybe it's not a stable release and will not get (re)indexed.)\n"; + next; + } + } + } + if ($blurb) { + my $eta; + { + my $ctf = "$PAUSE::Config->{CRONPATH}/CRONTAB.ROOT"; # crontabfile + unless (-f $ctf) { + $ctf = "/tmp/crontab.root"; + } + if (-f $ctf) { + open my $fh, "<", $ctf or die "XXX"; + local $/ = "\n"; + my $minute; + while (<$fh>) { + s/\#.*//; + next unless /mldistwatch/; + ($minute) = split " ", $_, 2; + last; + } + my $sc; + eval { $sc = Set::Crontab->new($minute,[0..59]); }; + if ($@) { + warn "Could not create a Crontab object: $@ (minute[$minute])"; + $eta = "N/A"; + } else { + my $now = time; + $now -= $now%60; + for (my $i = 1; $i<=60; $i++) { + my $fut = $now + $i * 60; + my $fum = int $fut % 3600 / 60; + next unless $sc->contains($fum); + $eta = gmtime( $fut + $PAUSE::Config->{RUNTIME_MLDISTWATCH} ) . " UTC"; + last; + } + } + } else { + warn "Not found: $ctf"; + $eta = "N/A"; + } + } + $pause->{blurb} = $blurb; + $pause->{eta} = $eta; + + my @to = $mgr->prepare_sendto($u, $pause->{User}, $PAUSE::Config->{ADMIN}); + my $mailbody = $c->render_to_string("email/user/reindex", format => "email"); + my $header = { + Subject => "Scheduled for reindexing $u->{userid}" + }; + $mgr->send_mail_multi(\@to, $header, $mailbody); + + $pause->{mailbody} = $mailbody; + } + + my %files = $c->manifind; + + foreach my $f (keys %files) { + if ( + $f =~ /readme$/ || + $f eq "CHECKSUMS" + ) { + delete $files{$f}; + next; + } + } + $pause->{files} = \%files; +} + +sub reset_version { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + my $u = $c->active_user_record; + + my $dbh = $mgr->connect; + local($dbh->{RaiseError}) = 0; + + my $blurb = ""; + my($usersubstr) = sprintf("%s/%s/%s/", + substr($u->{userid},0,1), + substr($u->{userid},0,2), + $u->{userid}, + ); + my($usersubstrlen) = length $usersubstr; + + my $sqls = "SELECT package, version, dist FROM packages + WHERE substring(dist,1,$usersubstrlen) = ?"; + my $sths = $dbh->prepare($sqls); + if ($req->param('SUBMIT_pause99_reset_version_forget')) { + my $sqls2 = "SELECT version FROM packages + WHERE package = ? AND substring(dist,1,$usersubstrlen) = ?"; + my $sths2 = $dbh->prepare($sqls2); + my $sqlu = "UPDATE packages + SET version='undef' + WHERE package = ? AND substring(dist,1,$usersubstrlen) = ?"; + my $sthu = $dbh->prepare($sqlu); + PKG: foreach my $f (@{$req->every_param('pause99_reset_version_PKG')}) { + $sths2->execute($f,$usersubstr); + my($version) = $sths2->fetchrow_array; + next PKG if $version eq 'undef'; + my $ret = $sthu->execute($f,$usersubstr); + $blurb .= sprintf( + "%s: %s '%s' => 'undef'\n", + $ret==0 ? "Not reset" : "Reset", + $f, + $version, + ); + } + } + + if ($blurb) { + $pause->{blurb} = $blurb; + + my @to = $mgr->prepare_sendto($u, $pause->{User}, $PAUSE::Config->{ADMIN}); + my $mailbody = $c->render_to_string("email/user/reset_version", format => "email"); + my $header = { + Subject => "Version reset for $u->{userid}" + }; + $mgr->send_mail_multi(\@to, $header, $mailbody); + + $pause->{mailbody} = $mailbody; + } + $sths->execute($usersubstr); + if ($sths->rows == 0) { + return; + } + + my %packages; + while (my($package, $version, $dist) = $sths->fetchrow_array) { + $packages{$package} = {version => $version, dist => $dist}; + } + $pause->{packages} = \%packages; +} + +sub tail_logfile { + my $c = shift; + my $pause = $c->stash(".pause"); + my $req = $c->req; + + my $tail = $req->param("pause99_tail_logfile_1") || 5000; + my $file = $PAUSE::Config->{PAUSE_LOG}; + if ($PAUSE::Config->{TESTHOST}) { + $file = "/usr/local/apache/logs/error_log"; # for testing + } + open my $fh, "<", $file or die "Could not open $file: $!"; + seek $fh, -$tail, 2; + local($/); + $/ = "\n"; + <$fh>; + $/ = undef; + + $pause->{tail} = <$fh>; +} + +sub change_passwd { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + + my $u = eval { $c->active_user_record }; + die PAUSE::Web::Exception->new(ERROR => "User not found", HTTP_STATUS => 401) if $@; + + if (uc $req->method eq 'POST' and $req->param("pause99_change_passwd_sub")) { + if (my $pw1 = $req->param("pause99_change_passwd_pw1")) { + if (my $pw2 = $req->param("pause99_change_passwd_pw2")) { + if ($pw1 eq $pw2) { + # create a new crypted password, store it, report + my $pwenc = PAUSE::Crypt::hash_password($pw1); + my $dbh = $mgr->authen_connect; + my $sql = qq{UPDATE $PAUSE::Config->{AUTHEN_USER_TABLE} + SET $PAUSE::Config->{AUTHEN_PASSWORD_FLD} = ?, + forcechange = ?, + changed = ?, + changedby = ? + WHERE $PAUSE::Config->{AUTHEN_USER_FLD} = ?}; + # warn "sql[$sql]"; + my $rc = $dbh->do($sql,undef, + $pwenc,0,time,$pause->{User}{userid},$u->{userid}); + warn "rc[$rc]"; + die PAUSE::Web::Exception + ->new(ERROR => + sprintf qq[Could not set password: '%s'], $dbh->errstr + ) unless $rc; + if ($rc == 0) { + $sql = qq{INSERT INTO $PAUSE::Config->{AUTHEN_USER_TABLE} + ($PAUSE::Config->{AUTHEN_USER_FLD}, + $PAUSE::Config->{AUTHEN_PASSWORD_FLD}, + forcechange, + changed, + changedby ) VALUES + (?, ?, ?, ?, ?) + }; + $rc = $dbh->do($sql,undef, + $u->{userid}, + $pwenc, + 0, + time, + $pause->{User}{userid}, + $u->{userid} + ); + die PAUSE::Web::Exception + ->new(ERROR => + sprintf qq[Could not insert user record: '%s'], $dbh->errstr + ) unless $rc; + } + for my $anon ($pause->{User}, $u) { + die PAUSE::Web::Exception + ->new(ERROR => "Panic: unknown user") unless $anon->{userid}; + next if $anon->{fullname}; + $mgr->log({level => 'error', message => "Unknown fullname for $anon->{userid}!" }); + } + $pause->{password_stored} = 1; + + my @to = $mgr->prepare_sendto($u, $pause->{User}); + my $header = {Subject => "Password Update"}; + my $mailbody = $c->render_to_string("email/user/change_passwd", format => "email"); + $mgr->send_mail_multi(\@to, $header, $mailbody); + + # Remove used token + $sql = qq{DELETE FROM abrakadabra WHERE user = ?}; + $rc = $dbh->do($sql, undef, $u->{userid}); + die PAUSE::Web::Exception + ->new(ERROR => + sprintf qq[Could not delete token: '%s'], $dbh->errstr + ) unless $rc; + $mgr->log({level => 'info', message => "Removed used token for $u->{userid}" }); + } else { + die PAUSE::Web::Exception + ->new(ERROR => "The two passwords didn't match."); + } + } else { + die PAUSE::Web::Exception + ->new(ERROR => "You need to fill in the same password in both fields."); + } + } else { + die PAUSE::Web::Exception + ->new(ERROR => "Please fill in the form with passwords."); + } + } +} + +sub pause_logout { + my $c = shift; + $c->serve_pause_doc("logout.html", \&_fix_logout); +} + +sub _fix_logout { + my $html = shift; + my $rand = rand 1; + # the redirect solutions fail miserably the second time when tried + # with the exact same querystring again. + $html =~ s/__RANDOMSTRING__/$rand/g; + $html; +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Controller/User/Cred.pm b/lib/pause_2025/PAUSE/Web/Controller/User/Cred.pm new file mode 100644 index 000000000..680ed8c4c --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Controller/User/Cred.pm @@ -0,0 +1,221 @@ +package PAUSE::Web::Controller::User::Cred; + +use Mojo::Base "Mojolicious::Controller"; +use Email::Address; +use PAUSE::Web::Util::Encode; +use Text::Unidecode; + +sub edit { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + my ($u, $nu); # user, newuser + $u = $c->active_user_record; + + # @allmeta *must* be the union of meta and secmeta + my @meta = qw( fullname asciiname email homepage cpan_mail_alias ustatus); + my @secmeta = qw(secretemail); + my @allmeta = qw( fullname asciiname email secretemail homepage cpan_mail_alias ustatus); + + my $cpan_alias = lc($u->{userid}) . '@cpan.org'; + + my %meta = map {$_ => 1} @allmeta; + + my $consistentsubmit = 0; + if (uc $req->method eq 'POST' and $req->param("pause99_edit_cred_sub")) { + my $wantemail = $req->param("pause99_edit_cred_email"); + my $wantsecretemail = $req->param("pause99_edit_cred_secretemail"); + my $wantalias = $req->param("pause99_edit_cred_cpan_mail_alias"); + my $addr_spec = $Email::Address::addr_spec; + if ($wantemail=~/^\s*$/ && $wantsecretemail=~/^\s*$/) { + $pause->{error}{no_email} = 1; + } elsif ($wantalias eq "publ" && $wantemail=~/^\s*$/) { + $pause->{error}{no_public_email} = 1; + } elsif ($wantalias eq "publ" && $wantemail=~/\Q$cpan_alias\E/i) { + $pause->{error}{public_is_cpan_alias} = 1; + } elsif ($wantalias eq "secr" && $wantsecretemail=~/^\s*$/) { + $pause->{error}{no_secret_email} = 1; + } elsif ($wantalias eq "secr" && $wantsecretemail=~/\Q$cpan_alias\E/i) { + $pause->{error}{secret_is_cpan_alias} = 1; + } elsif (defined $wantsecretemail && $wantsecretemail!~/^\s*$/ && $wantsecretemail!~/^\s*$addr_spec\s*$/) { + $pause->{error}{invalid_secret} = 1; + } elsif (defined $wantemail && $wantemail!~/^\s*$/ && $wantemail!~/^\s*$addr_spec\s*$/ && $wantemail ne 'CENSORED') { + $pause->{error}{invalid_public} = 1; + } else { + $consistentsubmit = 1; + } + + if ($consistentsubmit) { + # more testing: make sure that we have in asciiname only ascii + if (my $wantasciiname = $req->param("pause99_edit_cred_asciiname")) { + if ($wantasciiname =~ /[^\040-\177]/) { + $pause->{error}{not_ascii} = 1; + $consistentsubmit = 0; + } else { + # set asciiname to empty if it equals fullname + my $wantfullname = $req->param("pause99_edit_cred_fullname"); + if ($wantfullname eq $wantasciiname) { + $req->param("pause99_edit_cred_asciiname", ""); + } + } + } else { + # set asciiname on our own if they don't supply it + my $wantfullname = $req->param("pause99_edit_cred_fullname"); + if ($wantfullname =~ /[^\040-\177]/) { + $wantfullname = PAUSE::Web::Util::Encode::any2utf8($wantfullname); + $wantasciiname = Text::Unidecode::unidecode($wantfullname); + $req->param("pause99_edit_cred_asciiname", $wantasciiname); + } + } + } + } else { + for my $field (@allmeta) { + unless ($meta{$field}){ + warn "Someone tried strange field[$field], ignored"; + next; + } + if ( $field eq "ustatus" ) { + if ( $u->{"ustatus"} eq "active" ) { + next; + } + } + $req->param("pause99_edit_cred_$field" => $u->{$field}); + } + } + + if ($consistentsubmit) { + $pause->{consistentsubmit} = 1; + my $saw_a_change; + my $now = time; + + # We once duplicated nearly exactly the same code of 100 lines. + # Once for secretemail, once for the other attributes. Lines + # marked with four hashmarks are the ones that differ. Why not + # make it a function? Well, that function would have to take at + # least 5 arguments and we want some variables in the lexical + # scope. So I made it a loop for two complicated arrays. + for my $quid ( + [ + "connect", + \@meta, + "users", + "userid", + 1 + ], + ["authen_connect", + \@secmeta, + $PAUSE::Config->{AUTHEN_USER_TABLE}, + $PAUSE::Config->{AUTHEN_USER_FLD}, + 0 + ] + ) { + my($connect,$atmeta,$table,$column,$mailto_admins) = @$quid; + my(@set,@mailblurb); + my $dbh = $mgr->$connect(); #### the () for older perls + for my $field (@$atmeta) { #### + # warn "field[$field]"; + # Ignore fields we do not intend to change + unless ($meta{$field}){ + warn "Someone tried strange field[$field], ignored"; + next; + } + # find out the form field name + my $form_field = "pause99_edit_cred_$field"; + if ( $field eq "ustatus" ) { + if ( $u->{"ustatus"} eq "active" ) { + next; + } elsif (!$req->param($form_field)) { + $req->param($form_field,"unused"); + } + } + # $s is the value they entered + my $s_raw = $req->param($form_field) || ""; + # we're in edit_cred + my $s; + $s = PAUSE::Web::Util::Encode::any2utf8($s_raw); + $s =~ s/^\s+//; + $s =~ s/\s+\z//; + if ($s ne $s_raw) { + $req->param($form_field,$s); + } + $nu->{$field} = $s; + $u->{$field} = "" unless defined $u->{$field}; + my $mb; # mailblurb + if ($u->{$field} ne $s) { + $saw_a_change = 1; + # No UTF8 running before we have the system walking + # my $utf = $mgr->formfield_as_utf8($s); + # unless ( $s eq $utf ) { + # $req->param($form_field, $utf); + # $s = $utf; + # } + # next if $pause->{User}{$field} eq $s; + + # not ?-ising this as rely on quote() method + push @set, "$field = " . $dbh->quote($s); + $mb = {field => $field, value => $s, was => $u->{$field}}; + if ($field eq "ustatus") { + push @set, "ustatus_ch = NOW()"; + } + $u->{$field} = $s; + } else { + $mb = {field => $field, value => $s}; + } + if ($field eq "secretemail") { + $mb = {field => $field, value => "CENSORED"}; + } + push @mailblurb, $mb; + } + + if (@set) { + my @query_params = ($now, $pause->{User}{userid}, $u->{userid}); + my $sql = "UPDATE $table SET " . #### + join(", ", @set, "changed = ?, changedby=?") . + " WHERE $column = ?"; #### + $pause->{mailblurb} = \@mailblurb; + my $mailblurb = $c->render_to_string("email/user/cred/edit", format => "email"); + # warn "sql[$sql]mailblurb[$mailblurb]"; + # die; + if ($dbh->do($sql, undef, @query_params)) { + $pause->{registered}{$table} = 1; + $nu = $c->active_user_record($u->{userid}); + if ($nu->{userid} && $nu->{userid} eq $pause->{User}{userid}) { + $pause->{User} = $nu; + } + # Send separate emails to user and public places because + # CC leaks secretemail to others + my @to; + my %umailset; + for my $lu ($u, $nu) { + for my $att (qw(secretemail email)) { + if ($lu->{$att}){ + $umailset{qq{<$lu->{$att}>}} = 1; + last; + } + } + } + push @to, join ", ", keys %umailset; + push @to, $mgr->config->mailto_admins if $mailto_admins; + my $header = {Subject => "User update for $u->{userid}"}; + $mgr->send_mail_multi(\@to,$header, $mailblurb); + } else { +# FIXME + push @{$pause->{ERROR}}, sprintf(qq{Could not enter the data + into the database: %s.},$dbh->errstr); + } + } + } # end of quid loop + + if ($saw_a_change) { + $pause->{saw_a_change} = 1; + # expire temporary token to free mailpw for immediate use + my $sql = qq{DELETE FROM abrakadabra + WHERE user = ?}; + my $dbh = $mgr->authen_connect(); + $dbh->do($sql,undef,$u->{userid}); + } + } +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Controller/User/Distperms.pm b/lib/pause_2025/PAUSE/Web/Controller/User/Distperms.pm new file mode 100644 index 000000000..fcc96716c --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Controller/User/Distperms.pm @@ -0,0 +1,554 @@ +package PAUSE::Web::Controller::User::Distperms; + +use Mojo::Base "Mojolicious::Controller"; + +sub peek { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + + unless ($req->param("pause99_peek_dist_perms_query")) { + $req->param("pause99_peek_dist_perms_query" => $pause->{User}{userid}); + } + unless ($req->param("pause99_peek_dist_perms_by")) { + $req->param("pause99_peek_dist_perms_by" => "a"); + } + + if (my $qterm = $req->param("pause99_peek_dist_perms_query")) { + my $by = $req->param("pause99_peek_dist_perms_by"); + my $query = qq{SELECT packages.distname, + GROUP_CONCAT(DISTINCT primeur.userid ORDER BY primeur.userid), + GROUP_CONCAT(DISTINCT perms.userid ORDER BY perms.userid) + FROM packages LEFT JOIN primeur ON primeur.package=packages.package + LEFT JOIN perms ON perms.package=packages.package AND primeur.userid <> perms.userid + }; + + my $db = $mgr->connect; + my @res; + my %seen; + my $where; + my @bind; + if ($by =~ /^d/) { + @bind = ($qterm); + if ($by eq "de") { + $where = qq{WHERE packages.distname=? GROUP BY packages.distname}; + } else { + $where = qq{WHERE packages.distname LIKE ? GROUP BY packages.distname LIMIT 1000}; + # I saw 5.7.3 die with Out Of Memory on the query "%" when no + # Limit was applied + } + } elsif ($by eq "a") { + @bind = ($qterm, $qterm); + $where = qq{WHERE primeur.userid=? OR perms.userid=? GROUP BY packages.distname}; + } else { + die PAUSE::Web::Exception + ->new(ERROR => "Illegal parameter for pause99_peek_dist_perms_by"); + } + $query .= $where; + my $sth = $db->prepare($query); + $sth->execute(@bind); + if ($sth->rows > 0) { + # warn sprintf "query[%s]qterm[%s]rows[%d]", $query, $qterm, $sth->rows; + while (my @row = $mgr->fetchrow($sth, "fetchrow_array")) { + if ($seen{$row[0]}++){ + # warn "Ignoring row[$row[0]][$row[1]]"; + next; + } + push @res, \@row; + } + } + $sth->finish; + if (@res) { + my $dbh = $mgr->connect; + my @column_names = qw(dist owner comaint); + my $output_format = $req->param("OF"); + if ($output_format){ + my @hres; + for my $row (@res) { + push @hres, { map {$column_names[$_] => $row->[$_] } 0..$#$row }; + } + if ($output_format eq "YAML") { + return $c->render_yaml(\@hres); + } else { + die "not supported OF=$output_format" + } + } + $pause->{column_names} = \@column_names; + + @res = sort { + $a->[0] cmp $b->[0] + || + $a->[1] cmp $b->[1] + || + $a->[2] cmp $b->[2] + } @res; + + $pause->{rows} = \@res; + } + } +} + +sub move_dist_primary { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + + my $u = $c->active_user_record; + + my $db = $mgr->connect; + + my $all_dists = $c->all_pdists($u); + + if ( + $req->param("SUBMIT_pause99_move_dist_primary") + ) { + eval { + my(@seldists, $other_user); + if (@seldists = @{$req->every_param("pause99_move_dist_primary_d")} + and + $other_user = $req->param("pause99_move_dist_primary_a") + ) { + $other_user = uc $other_user; + my $sth1 = $db->prepare("SELECT userid + FROM users + WHERE userid=?"); + $sth1->execute($other_user); + die PAUSE::Web::Exception + ->new(ERROR => "$other_user is not a valid userid.") + unless $sth1->rows; + local($db->{RaiseError}) = 0; + my $sth = $db->prepare("UPDATE primeur SET userid=? WHERE package=?"); + my @results; + for my $seldist (@seldists) { + die PAUSE::Web::Exception + ->new(ERROR => "You do not seem to be maintainer of $seldist") + unless exists $all_dists->{$seldist}; + my $mods = $db->selectcol_arrayref( + q{SELECT primeur.package + FROM primeur JOIN packages ON primeur.package = packages.package + WHERE packages.distname=? AND primeur.userid=?}, + undef, $seldist, $u->{userid}); + for my $selmod (@$mods) { + my $ret = $sth->execute($other_user,$selmod); + my $err = ""; + $err = $db->errstr unless defined $ret; + $ret ||= ""; + warn "DEBUG: seldist[$seldist]selmod[$selmod]other_user[$other_user]ret[$ret]err[$err]"; + if ($ret) { + push @results, { + user => $other_user, + mod => $selmod, + dist => $seldist, + }; + } else { + push @results, { + user => $other_user, + mod => $selmod, + dist => $seldist, + error => $err, + }; + } + } + } + $pause->{results} = \@results; + } + }; + if ($@) { + $pause->{error} = $@->{ERROR}; + } + } + + $all_dists = $c->all_pdists($u); # again + my @all_dists = map {[$_, $all_dists->{$_}]} sort keys %$all_dists; + $pause->{dists} = \@all_dists; + + if (@all_dists == 1) { + $req->param("pause99_move_dist_primary_d" => $all_dists[0][0]); + } +} + +sub remove_dist_primary { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + my $u = $c->active_user_record; + + my $db = $mgr->connect; + + my $all_dists = $c->all_pdists($u); + + if (0) { + # here I discovered that Apache::Request has case-insensitive keys + my %p = map { $_, [ $req->every_param($_)] } @{$req->param->names}; + require Data::Dumper; + my $message = "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([\%p],[qw()])->Indent(1)->Useqq(1)->Dump; + $c->app->pause->log({level => 'debug', message => $message}); + } + + if ( + $req->param("SUBMIT_pause99_remove_dist_primary") + ) { + eval { + my(@seldists); + if (@seldists = @{$req->every_param("pause99_remove_dist_primary_d")} + ) { + local($db->{RaiseError}) = 0; + my $sth = $db->prepare("UPDATE primeur SET userid=? WHERE userid=? AND package=?"); + + my @results; + for my $seldist (@seldists) { + die PAUSE::Web::Exception + ->new(ERROR => "You do not seem to be maintainer of $seldist") + unless exists $all_dists->{$seldist}; + my $mods = $db->selectcol_arrayref( + q{SELECT primeur.package + FROM primeur JOIN packages ON primeur.package = packages.package + WHERE packages.distname=? AND primeur.userid=?}, + undef, $seldist, $u->{userid}); + for my $selmod (@$mods) { + my $ret = $sth->execute('ADOPTME',$u->{userid},$selmod); + my $err = ""; + $err = $db->errstr unless defined $ret; + $ret ||= ""; + warn "DEBUG: seldist[$seldist]selmod[$selmod]ret[$ret]err[$err]"; + if ($ret) { + push @results, { + user => $u->{userid}, + mod => $selmod, + dist => $seldist, + }; + } else { + push @results, { + user => $u->{userid}, + mod => $selmod, + dist => $seldist, + error => $err, + }; + } + } + } + $pause->{results} = \@results; + } + }; + } + + $all_dists = $c->all_pdists($u); # again + my @all_dists = map {[$_, $all_dists->{$_}]} sort keys %$all_dists; + $pause->{dists} = \@all_dists; + + if (@all_dists == 1) { + $req->param("pause99_remove_dist_primary_d" => $all_dists[0][0]); + } +} + +sub make_dist_comaint { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + my $u = $c->active_user_record; + # warn "u->userid[%s]", $u->{userid}; + + my $db = $mgr->connect; + + my $all_dists = $c->all_pdists($u); + # warn sprintf "all_pdists[%s]", join("|", keys %$all_pdists); + + if ( + $req->param("SUBMIT_pause99_make_dist_comaint") + ) { + eval { + my(@seldists,$other_user); + if (@seldists = @{$req->every_param("pause99_make_dist_comaint_d")} + and + $other_user = $req->param("pause99_make_dist_comaint_a") + ) { + $other_user = uc $other_user; + my $sth1 = $db->prepare("SELECT userid + FROM users + WHERE userid=?"); + $sth1->execute($other_user); + die PAUSE::Web::Exception + ->new(ERROR => sprintf( + "$other_user is not a valid userid.", + ) + ) + unless $sth1->rows; + local($db->{RaiseError}) = 0; + my $sth = $db->prepare("INSERT INTO perms (package,lc_package,userid) + VALUES (?,?,?)"); + my @results; + for my $seldist (@seldists) { + die PAUSE::Web::Exception + ->new(ERROR => "You do not seem to be maintainer of $seldist") + unless exists $all_dists->{$seldist}; + my $mods = $db->selectcol_arrayref( + q{SELECT primeur.package + FROM primeur JOIN packages ON primeur.package = packages.package + WHERE packages.distname=? AND primeur.userid=?}, + undef, $seldist, $u->{userid}); + for my $selmod (@$mods) { + my $ret = $sth->execute($selmod,lc $selmod,$other_user); + my $err = ""; + $err = $db->errstr unless defined $ret; + $ret ||= ""; + warn "DEBUG: seldist[$seldist]selmod[$selmod]other_user[$other_user]ret[$ret]err[$err]"; + if ($ret) { + push @results, { + user => $other_user, + mod => $selmod, + dist => $seldist, + }; + } elsif ($err =~ /Duplicate entry/) { + push @results, { + user => $other_user, + mod => $selmod, + dist => $seldist, + duplicated => 1, + }; + } else { + push @results, { + user => $other_user, + mod => $selmod, + dist => $seldist, + error => $err, + }; + } + } + $pause->{results} = \@results; + } + } + }; + if ($@) { + $pause->{error} = $@->{ERROR}; + } + } + + $all_dists = $c->all_pdists($u); # again + my @all_dists = map {[$_, $all_dists->{$_}]} sort keys %$all_dists; + $pause->{dists} = \@all_dists; + + if (@all_dists == 1) { + $req->param("pause99_make_dist_comaint_d" => $all_dists[0][0]); + } +} + +sub remove_dist_comaint { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + my $u = $c->active_user_record; + + my $db = $mgr->connect; + + my $all_dists = $c->all_pdists($u); + my $all_comaints = $c->all_comaints($all_dists,$u); + + if ( + $req->param("SUBMIT_pause99_remove_dist_comaint") + ) { + eval { + my @sel = @{$req->every_param("pause99_remove_dist_comaint_tuples")}; + my $sth1 = $db->prepare("DELETE FROM perms WHERE package=? AND userid=?"); + if (@sel) { + my @results; + for my $sel (@sel) { + my($seldist,$otheruser) = $sel =~ /^(\S+)\s--\s(\S+)$/; + die PAUSE::Web::Exception + ->new(ERROR => "You do not seem to be owner of $seldist.") + unless exists $all_dists->{$seldist}; + unless (exists $all_comaints->{$sel}) { + push @results, { + sel => $sel, + not_exists => 1, + }; + next; + } + my $mods = $db->selectcol_arrayref( + q{SELECT primeur.package + FROM primeur JOIN packages ON primeur.package = packages.package + WHERE packages.distname=? AND primeur.userid=?}, + undef, $seldist, $u->{userid}); + for my $selmod (@$mods) { + my $ret = $sth1->execute($selmod,$otheruser); + my $err = ""; + $err = $db->errstr unless defined $ret; + $ret ||= ""; + warn "DEBUG: seldist[$seldist]selmod[$selmod]ret[$ret]err[$err]"; + if ($ret) { + push @results, { + user => $otheruser, + mod => $selmod, + dist => $seldist, + }; + } else { + push @results, { + user => $otheruser, + mod => $selmod, + dist => $seldist, + error => $err, + }; + } + } + } + $pause->{results} = \@results; + } + }; + if ($@) { + $pause->{error} = $@->{ERROR}; + } + } + + $all_comaints = $c->all_comaints($all_dists,$u); # again + my @all = sort keys %$all_comaints; + $pause->{dists} = \@all; +} + +sub giveup_dist_comaint { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + my $u = $c->active_user_record; + my $db = $mgr->connect; + + my $all_dists = $c->all_only_cdists($u); + + if ( + $req->param("SUBMIT_pause99_giveup_dist_comaint") + ) { + eval { + my(@seldists); + if (@seldists = @{$req->every_param("pause99_giveup_dist_comaint_d")} + ) { + local($db->{RaiseError}) = 0; + my $sth = $db->prepare("DELETE FROM perms WHERE package=? AND userid=?"); + + my @results; + for my $seldist (@seldists) { + die PAUSE::Web::Exception + ->new(ERROR => "You do not seem to be co-maintainer of $seldist") + unless exists $all_dists->{$seldist}; + my $mods = $db->selectcol_arrayref( + q{SELECT perms.package + FROM perms JOIN packages ON perms.package = packages.package + WHERE packages.distname=? AND perms.userid=?}, + undef, $seldist, $u->{userid}); + for my $selmod (@$mods) { + my $ret = $sth->execute($selmod,$u->{userid}); + my $err = ""; + $err = $db->errstr unless defined $ret; + $ret ||= ""; + warn "DEBUG: seldist[$seldist]selmod[$selmod]ret[$ret]err[$err]"; + if ($ret) { + push @results, { + user => $u->{userid}, + mod => $selmod, + dist => $seldist, + }; + delete $all_dists->{$seldist}; + } else { + push @results, { + user => $u->{userid}, + mod => $selmod, + dist => $seldist, + error => $err, + }; + } + } + } + $pause->{results} = \@results; + } + }; + if ($@) { + $pause->{error} = $@->{ERROR}; + } + } + + $all_dists = $c->all_only_cdists($u); # again + my @all_dists = map {[$_, $all_dists->{$_}]} sort keys %$all_dists; + $pause->{dists} = \@all_dists; + + if (@all_dists == 1) { + $req->param("pause99_giveup_dist_comaint_d" => $all_dists[0][0]); + } +} + +sub all_pdists { + my ($c, $u) = @_; + my $mgr = $c->app->pause; + my $db = $mgr->connect; + my(%all_dists); +# XXX: This query was too slow under mysql 5.1... +# qq{SELECT packages.distname, GROUP_CONCAT(DISTINCT p3.userid ORDER BY p3.userid) +# FROM packages JOIN primeur ON primeur.userid = ? AND primeur.package=packages.package +# LEFT JOIN packages AS p2 ON packages.distname = p2.distname +# LEFT JOIN primeur AS p3 ON p2.package = p3.package GROUP BY packages.distname}); + my $sth2 = $db->prepare( + qq{SELECT packages.distname + FROM packages JOIN primeur ON primeur.userid = ? AND primeur.package=packages.package}); + $sth2->execute($u->{userid}); + while (my($distname) = $mgr->fetchrow($sth2, "fetchrow_array")) { + next if $distname eq ''; + my $owners = $db->selectcol_arrayref( + qq{SELECT DISTINCT(userid) FROM primeur JOIN packages ON packages.distname = ? AND primeur.package = packages.package}, + undef, $distname); + $all_dists{$distname} = join ',', @$owners; + } + $sth2->finish; + \%all_dists; +} + +sub all_cdists { + my ($c, $u) = @_; + my $mgr = $c->app->pause; + my $db = $mgr->connect; + my(%all_dists); + my $sth2 = $db->prepare(qq{SELECT packages.distname, GROUP_CONCAT(DISTINCT primeur.userid ORDER BY primeur.userid) + FROM packages + JOIN perms ON perms.userid = ? AND perms.package = packages.package + LEFT JOIN primeur ON packages.package = primeur.package + GROUP BY packages.distname}); + $sth2->execute($u->{userid}); + while (my($id, $owner) = $mgr->fetchrow($sth2, "fetchrow_array")) { + $all_dists{$id} = $owner; + } + $sth2->finish; + \%all_dists; +} + +sub all_only_cdists { + my($c,$u) = @_; + my $all_pdists = $c->all_pdists($u); + my $all_dists = $c->all_cdists($u); + + for my $k (keys %$all_pdists) { + delete $all_dists->{$k}; + } + $all_dists; +} + +sub all_comaints { + my ($c, $all_dists, $u) = @_; + my $mgr = $c->app->pause; + my $result = {}; + return $result unless %$all_dists; + my $db = $mgr->connect; + my $or = join " OR\n", map { "packages.distname='$_'" } keys %$all_dists; + my $sth2 = $db->prepare(qq{SELECT packages.distname, userid, perms.package + FROM perms LEFT JOIN packages ON perms.package = packages.package + WHERE userid <> '$u->{userid}' AND ( $or ) + }); + $sth2->execute; + while (my($d,$i,$p) = $mgr->fetchrow($sth2,"fetchrow_array")) { + $result->{"$d -- $i"}{$p} = undef; + warn "d[$d]p[$p]i[$i]"; + } + return $result; +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Controller/User/Files.pm b/lib/pause_2025/PAUSE/Web/Controller/User/Files.pm new file mode 100644 index 000000000..822fc3790 --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Controller/User/Files.pm @@ -0,0 +1,218 @@ +package PAUSE::Web::Controller::User::Files; + +use Mojo::Base "Mojolicious::Controller"; +use HTTP::Date (); +use File::pushd; +use PAUSE (); + +sub show { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $u = $c->active_user_record; + + my $dbh = $mgr->connect; + local($dbh->{RaiseError}) = 0; + my $userhome = PAUSE::user2dir($u->{userid}); + $pause->{userhome} = $userhome; + + my $pushd = eval { pushd("$PAUSE::Config->{MLROOT}/$userhome") } or return; + warn "DEBUG: MLROOT[$PAUSE::Config->{MLROOT}] userhome[$userhome] E:M:V[$ExtUtils::Manifest::VERSION]"; + + my $time = time; + my %files = $c->manifind; + my (%deletes, %whendele, $sth); + if ( + $sth = $dbh->prepare(qq{SELECT deleteid, changed + FROM deletes + WHERE deleteid + LIKE ?}) + and + $sth->execute("$userhome/%") + and + $sth->rows + ) { + my $dhash; + while ($dhash = $mgr->fetchrow($sth, "fetchrow_hashref")) { + $dhash->{deleteid} =~ s/\Q$userhome\E\///; + $deletes{$dhash->{deleteid}}++; + $whendele{$dhash->{deleteid}} = $dhash->{changed}; + } + } + $sth->finish if ref $sth; + + my $indexed = $c->indexed($dbh, $u->{userid}); + + foreach my $f (keys %files) { + unless (stat $f) { + warn "ALERT: Could not stat f[$f]: $!"; + next; + } + my $blurb = $deletes{$f} ? + $c->scheduled($whendele{$f}) : + HTTP::Date::time2str((stat _)[9]); + $files{$f} = {stat => -s _, blurb => $blurb, indexed => $indexed->{$f} }; + } + $pause->{files} = \%files; +} + +sub delete { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + my $u = $c->active_user_record; + + my $dbh = $mgr->connect; + local($dbh->{RaiseError}) = 0; + my $userhome = PAUSE::user2dir($u->{userid}); + $pause->{userhome} = $userhome; + + my $pushd = eval { pushd("$PAUSE::Config->{MLROOT}/$userhome") } or return; + warn "DEBUG: MLROOT[$PAUSE::Config->{MLROOT}] userhome[$userhome] ExtUtils:Manifest:VERSION[$ExtUtils::Manifest::VERSION]"; + + my $time = time; + my $blurb = ""; + if ($req->param('SUBMIT_pause99_delete_files_delete')) { + + foreach my $f (@{$req->every_param('pause99_delete_files_FILE')}) { + if ($f =~ m,^/, || $f =~ m,/\.\./,) { + $blurb .= "WARNING: illegal filename: $userhome/$f\n"; + next; + } + unless (-f $f){ + $blurb .= "WARNING: file not found: $userhome/$f\n"; + next; + } + if ($f =~ m{ (^|/) CHECKSUMS }x) { + $blurb .= "WARNING: CHECKSUMS not erasable: $userhome/$f\n"; + next; + } + $dbh->do( + "INSERT INTO deletes VALUES (?, ?, ?)", undef, + "$userhome/$f", $time, "$pause->{User}{userid}" + ) or next; + + $blurb .= "\$CPAN/authors/id/$userhome/$f\n"; + + # README + next if $f =~ /\.readme$/; + my $readme = $f; + $readme =~ s/(\.tar.gz|\.zip)$/.readme/; + if ($readme ne $f && -f $readme) { + $dbh->do( + q{INSERT INTO deletes VALUES (?,?,?)}, undef, + "$userhome/$readme", $time, $pause->{User}{userid}, + ) or next; + $blurb .= "\$CPAN/authors/id/$userhome/$readme\n"; + } + } + } elsif ($req->param('SUBMIT_pause99_delete_files_undelete')) { + foreach my $f (@{$req->every_param('pause99_delete_files_FILE')}) { + my $sql = "DELETE FROM deletes WHERE deleteid = ?"; + $dbh->do( + $sql, undef, + "$userhome/$f" + ) or warn sprintf "FAILED Query: %s/: %s", $sql, "$userhome/$f", $DBI::errstr; + } + } + + if ($blurb) { + $pause->{blurb} = $blurb; + $blurb = $c->render_to_string("email/user/delete_files", format => "email"); + + my %umailset; + my $name = $u->{asciiname} || $u->{fullname} || ""; + my $Uname = $pause->{User}{asciiname} || $pause->{User}{fullname} || ""; + if ($u->{secretemail}) { + $umailset{qq{"$name" <$u->{secretemail}>}} = 1; + } elsif ($u->{email}) { + $umailset{qq{"$name" <$u->{email}>}} = 1; + } + if ($u->{userid} ne $pause->{User}{userid}) { + if ($pause->{User}{secretemail}) { + $umailset{qq{"$Uname" <$pause->{User}{secretemail}>}} = 1; + }elsif ($pause->{User}{email}) { + $umailset{qq{"$Uname" <$pause->{User}{email}>}} = 1; + } + } + $umailset{$PAUSE::Config->{ADMIN}} = 1; + my @to = keys %umailset; + my $header = { + Subject => "Files of $u->{userid} scheduled for deletion" + }; + $mgr->send_mail_multi(\@to, $header, $blurb); + } + + my %files = $c->manifind; + my (%deletes, %whendele, $sth); + if ( + $sth = $dbh->prepare(qq{SELECT deleteid, changed + FROM deletes + WHERE deleteid + LIKE ?}) #} + and + $sth->execute("$userhome/%") + and + $sth->rows + ) { + my $dhash; + while ($dhash = $mgr->fetchrow($sth, "fetchrow_hashref")) { + $dhash->{deleteid} =~ s/\Q$userhome\E\///; + $deletes{$dhash->{deleteid}}++; + $whendele{$dhash->{deleteid}} = $dhash->{changed}; + } + } + $sth->finish if ref $sth; + + my $indexed = $c->indexed($dbh, $u->{userid}); + + foreach my $f (keys %files) { + unless (stat $f) { + warn "ALERT: Could not stat f[$f]: $!"; + next; + } + my $blurb = $deletes{$f} ? + $c->scheduled($whendele{$f}) : + HTTP::Date::time2str((stat _)[9]); + $files{$f} = {stat => -s _, blurb => $blurb, indexed => $indexed->{$f} }; + $pause->{deleting_indexed_files} = 1 if $deletes{$f} && $indexed->{$f}; + } + $pause->{files} = \%files; +} + +sub scheduled { + my ($c, $when) = @_; + my $time = time; + my $expires = $when + ($PAUSE::Config->{DELETES_EXPIRE} + || 60*60*24*2); + my $return = "Scheduled for deletion \("; + $return .= $time < $expires ? "due at " : "already expired at "; + $return .= HTTP::Date::time2str($expires); + $return .= "\)"; + $return; +} + +sub indexed { + my ($c, $dbh, $userid) = @_; + + my %indexed; + my $sth; + if ($sth = $dbh->prepare(qq{SELECT distinct(packages.dist) AS dist FROM packages JOIN uris ON packages.dist = uris.uriid WHERE packages.status = ? AND uris.userid = ?}) + and + $sth->execute('index', $userid) + and + $sth->rows + ) { + require CPAN::DistnameInfo; + my $dist; + while(($dist) = $sth->fetchrow_array) { + my $file = CPAN::DistnameInfo->new($dist)->filename or next; + $indexed{$file} = 1; + } + } + $sth->finish if ref $sth; + return \%indexed; +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Controller/User/Perms.pm b/lib/pause_2025/PAUSE/Web/Controller/User/Perms.pm new file mode 100644 index 000000000..43972fa6d --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Controller/User/Perms.pm @@ -0,0 +1,659 @@ +package PAUSE::Web::Controller::User::Perms; + +use Mojo::Base "Mojolicious::Controller"; + +sub peek { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + + unless ($req->param("pause99_peek_perms_query")) { + $req->param("pause99_peek_perms_query" => $pause->{User}{userid}); + } + unless ($req->param("pause99_peek_perms_by")) { + $req->param("pause99_peek_perms_by" => "a"); + } + + if (my $qterm = $req->param("pause99_peek_perms_query")) { + my $by = $req->param("pause99_peek_perms_by"); + my @query = ( + qq{SELECT primeur.package, + primeur.userid, + "first-come", + primeur.userid + FROM primeur LEFT JOIN users ON primeur.userid=users.userid + }, + qq{SELECT perms.package, + perms.userid, + "co-maint", + primeur.userid + FROM perms LEFT JOIN users ON perms.userid=users.userid + LEFT JOIN primeur ON perms.package=primeur.package + }, + ); + + my $db = $mgr->connect; + my @res; + my %seen; + for my $query (@query) { + my %fields = ( + "first-come" => { + package => "primeur.package", + userid => "primeur.userid", + }, + "co-maint" => { + package => "perms.package", + userid => "perms.userid", + } + ); + my($qtype) = $query =~ /\"(.+)\"/; + my($fmap) = $fields{$qtype}; + my $where; + if ($by =~ /^m/) { + if ($by eq "me") { + $where = qq{WHERE $fmap->{package}=?}; + } else { + $where = qq{WHERE $fmap->{package} LIKE ? LIMIT 1000}; + # I saw 5.7.3 die with Out Of Memory on the query "%" when no + # Limit was applied + } + } elsif ($by eq "a") { + $where = qq{WHERE $fmap->{userid}=?}; + } else { + die PAUSE::Web::Exception + ->new(ERROR => "Illegal parameter for pause99_peek_perms_by"); + } + $query .= $where; + my $sth = $db->prepare($query); + $sth->execute($qterm); + if ($sth->rows > 0) { + # warn sprintf "query[%s]qterm[%s]rows[%d]", $query, $qterm, $sth->rows; + while (my @row = $mgr->fetchrow($sth, "fetchrow_array")) { + if ($seen{join "|", @row[0,1]}++){ + # warn "Ignoring row[$row[0]][$row[1]]"; + next; + } + push @res, \@row; + } + } + $sth->finish; + } + if (@res) { + my $dbh = $mgr->connect; + for my $row (@res) { + # add the owner on column 3 + # will already be set except for co-maint modules where the + # owner is in the modlist but not first-come + $row->[3] ||= PAUSE::owner_of_module($row->[0], $dbh); + } + my @column_names = qw(module userid type owner); + my $output_format = $req->param("OF"); + if ($output_format){ + my @hres; + for my $row (@res) { + push @hres, { map {$column_names[$_] => $row->[$_] } 0..$#$row }; + } + if ($output_format eq "YAML") { + return $c->render_yaml(\@hres); + } else { + die "not supported OF=$output_format" + } + } + $pause->{column_names} = \@column_names; + + @res = sort { + $a->[0] cmp $b->[0] + || + $a->[1] cmp $b->[1] + || + $a->[2] cmp $b->[2] + || + $a->[3] cmp $b->[3] + } @res; + + $pause->{rows} = \@res; + } + } +} + +sub share { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + + my $subaction = $req->param("SUBACTION"); + unless ($subaction) { + ####################### 2.1 2.2 3.1 3.2 4.1 + SUBACTION: for my $sa (qw(movepr remopr makeco remocos remome)) { + if ($req->param("pause99_share_perms_$sa") + or + $req->param("SUBMIT_pause99_share_perms_$sa") + or + $req->param("weaksubmit_pause99_share_perms_$sa") + ) { + $subaction = $sa; + last SUBACTION; + } + } + } + $pause->{subaction} = $subaction; + my $u = $c->active_user_record; + + # warn sprintf "subaction[%s] u->userid[%s]", $subaction||"", $u->{userid}||""; + + unless ($subaction) { + # NOTE: the 6 submit buttons below are "weak" submit buttons. I + # want that people first reach the next page with more text and + # more options. + + my $dbh = $mgr->connect; + + { + my $all_mods = $c->all_pmods_not_mmods($u); + my @all_mods = sort keys %$all_mods; + $pause->{remove_primary} = \@all_mods; + } + + { + # it should be sufficiently helpful to prepare only makeco_m on + # these two submit buttons. For 3.2 people may be a little confused + # but it is so rarely needed that we do not worry. + my $all_mods = $c->all_pmods($u); + my @all_mods = sort keys %$all_mods; + $pause->{make_comaintainer} = \@all_mods; + } + + { + my $all_mods = $c->all_only_cmods($u); + my @all_mods = sort keys %$all_mods; + my %labels; + my @all_mods_with_label; + for my $m (@all_mods) { + # get the owner for modlist modules that don't have first-come + my $owner = $all_mods->{$m} || PAUSE::owner_of_module($m, $dbh) || '?'; + push @all_mods_with_label, ["$m => $owner", $m]; + } + + $pause->{remove_comaintainer} = \@all_mods_with_label; + } + + return; + } + + my $method = "_share_$subaction"; + $c->$method; +} + +sub move_primary { + my $c = shift; + $c->_share_movepr(@_); + $c->_prepare_dist_package_mapping; +} + +sub _share_movepr { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + + my $u = $c->active_user_record; + + my $db = $mgr->connect; + + my $all_mods = $c->all_pmods_not_mmods($u); + + if ( + $req->param("SUBMIT_pause99_share_perms_movepr") + ) { + eval { + my(@selmods, $other_user); + if (@selmods = @{$req->every_param("pause99_share_perms_pr_m")} + and + $other_user = $req->param("pause99_share_perms_movepr_a") + ) { + $other_user = uc $other_user; + my $sth1 = $db->prepare("SELECT userid + FROM users + WHERE userid=?"); + $sth1->execute($other_user); + die PAUSE::Web::Exception + ->new(ERROR => "$other_user is not a valid userid.") + unless $sth1->rows; + local($db->{RaiseError}) = 0; + my $sth = $db->prepare("UPDATE primeur SET userid=? WHERE package=?"); + my @results; + for my $selmod (@selmods) { + die PAUSE::Web::Exception + ->new(ERROR => "You do not seem to be maintainer of $selmod") + unless exists $all_mods->{$selmod}; + my $ret = $sth->execute($other_user,$selmod); + my $err = ""; + $err = $db->errstr unless defined $ret; + $ret ||= ""; + warn "DEBUG: selmod[$selmod]other_user[$other_user]ret[$ret]err[$err]"; + if ($ret) { + push @results, { + user => $other_user, + mod => $selmod, + }; + } else { + push @results, { + user => $other_user, + mod => $selmod, + error => $err, + }; + } + } + $pause->{results} = \@results; + } + }; + if ($@) { + $pause->{error} = $@->{ERROR}; + } + } + + $all_mods = $c->all_pmods_not_mmods($u); # again + my @all_mods = sort keys %$all_mods; + $pause->{mods} = \@all_mods; + + if (@all_mods == 1) { + $req->param("pause99_share_perms_pr_m" => $all_mods[0]); + } +} + +sub remove_primary { + my $c = shift; + $c->_share_remopr(@_); + $c->_prepare_dist_package_mapping; +} + +sub _share_remopr { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + my $u = $c->active_user_record; + + my $db = $mgr->connect; + + my $all_mods = $c->all_pmods_not_mmods($u); + + if (0) { + # here I discovered that Apache::Request has case-insensitive keys + my %p = map { $_, [ $req->every_param($_)] } @{$req->param->names}; + require Data::Dumper; + my $message = "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([\%p],[qw()])->Indent(1)->Useqq(1)->Dump; + $c->app->pause->log({level => 'debug', message => $message}); + } + + if ( + $req->param("SUBMIT_pause99_share_perms_remopr") + ) { + eval { + my(@selmods); + if (@selmods = @{$req->every_param("pause99_share_perms_pr_m")} + ) { + local($db->{RaiseError}) = 0; + my $sth = $db->prepare("UPDATE primeur SET userid = ? WHERE userid=? AND package=?"); + + my @results; + for my $selmod (@selmods) { + die PAUSE::Web::Exception + ->new(ERROR => "You do not seem to be maintainer of $selmod") + unless exists $all_mods->{$selmod}; + my $ret = $sth->execute('ADOPTME',$u->{userid},$selmod); + my $err = ""; + $err = $db->errstr unless defined $ret; + $ret ||= ""; + warn "DEBUG: selmod[$selmod]ret[$ret]err[$err]"; + if ($ret) { + push @results, { + user => $u->{userid}, + mod => $selmod, + }; + } else { + push @results, { + user => $u->{userid}, + mod => $selmod, + error => $err, + }; + } + } + $pause->{results} = \@results; + } + }; + } + + $all_mods = $c->all_pmods_not_mmods($u); # again + my @all_mods = sort keys %$all_mods; + $pause->{mods} = \@all_mods; + + if (@all_mods == 1) { + $req->param("pause99_share_perms_pr_m" => $all_mods[0]); + } +} + +sub make_comaint { + my $c = shift; + $c->_share_makeco(@_); + $c->_prepare_dist_package_mapping; +} + +sub _share_makeco { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + my $u = $c->active_user_record; + # warn "u->userid[%s]", $u->{userid}; + + my $db = $mgr->connect; + + my $all_pmods = $c->all_pmods($u); + # warn sprintf "all_pmods[%s]", join("|", keys %$all_pmods); + my $all_mods = {%$all_pmods}; + + if ( + $req->param("SUBMIT_pause99_share_perms_makeco") + ) { + eval { + my(@selmods,$other_user); + if (@selmods = @{$req->every_param("pause99_share_perms_makeco_m")} + and + $other_user = $req->param("pause99_share_perms_makeco_a") + ) { + $other_user = uc $other_user; + my $sth1 = $db->prepare("SELECT userid + FROM users + WHERE userid=?"); + $sth1->execute($other_user); + die PAUSE::Web::Exception + ->new(ERROR => sprintf( + "$other_user is not a valid userid.", + ) + ) + unless $sth1->rows; + local($db->{RaiseError}) = 0; + my $sth = $db->prepare("INSERT INTO perms (package,lc_package,userid) + VALUES (?,?,?)"); + + my @results; + for my $selmod (@selmods) { + die PAUSE::Web::Exception + ->new(ERROR => "You do not seem to be maintainer of $selmod") + unless exists $all_mods->{$selmod}; + my $ret = $sth->execute($selmod,lc $selmod,$other_user); + my $err = ""; + $err = $db->errstr unless defined $ret; + $ret ||= ""; + warn "DEBUG: selmod[$selmod]other_user[$other_user]ret[$ret]err[$err]"; + if ($ret) { + push @results, { + user => $other_user, + mod => $selmod, + }; + } elsif ($err =~ /Duplicate entry/) { + push @results, { + user => $other_user, + mod => $selmod, + duplicated => 1, + }; + } else { + push @results, { + user => $other_user, + mod => $selmod, + error => $err, + }; + } + $pause->{results} = \@results; + } + } + }; + if ($@) { + $pause->{error} = $@->{ERROR}; + } + } + + my @all_mods = sort keys %$all_mods; + $pause->{mods} = \@all_mods; + + if (@all_mods == 1) { + $req->param("pause99_share_perms_makeco_m" => $all_mods[0]); + } +} + +sub remove_comaint { + my $c = shift; + my $pause = $c->stash(".pause"); + $c->_share_remocos(@_); + $c->_prepare_dist_package_mapping([map {/^(\S+)/; $1} @{$pause->{mods}}]); +} + +sub _share_remocos { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + my $u = $c->active_user_record; + + my $db = $mgr->connect; + + my $all_mods = $c->all_pmods($u); + my $all_comaints = $c->all_comaints($all_mods,$u); + + if ( + $req->param("SUBMIT_pause99_share_perms_remocos") + ) { + eval { + my @sel = @{$req->every_param("pause99_share_perms_remocos_tuples")}; + my $sth1 = $db->prepare("DELETE FROM perms WHERE package=? AND userid=?"); + if (@sel) { + my @results; + for my $sel (@sel) { + my($selmod,$otheruser) = $sel =~ /^(\S+)\s--\s(\S+)$/; + die PAUSE::Web::Exception + ->new(ERROR => "You do not seem to be owner of $selmod.") + unless exists $all_mods->{$selmod}; + unless (exists $all_comaints->{$sel}) { + push @results, { + mod => $sel, + not_exists => 1, + }; + next; + } + my $ret = $sth1->execute($selmod,$otheruser); + my $err = ""; + $err = $db->errstr unless defined $ret; + $ret ||= ""; + warn "DEBUG: selmod[$selmod]ret[$ret]err[$err]"; + if ($ret) { + push @results, { + user => $otheruser, + mod => $selmod, + }; + } else { + push @results, { + user => $otheruser, + mod => $selmod, + error => $err, + }; + } + } + $pause->{results} = \@results; + } + }; + if ($@) { + $pause->{error} = $@->{ERROR}; + } + } + + $all_comaints = $c->all_comaints($all_mods,$u); # again + my @all = sort keys %$all_comaints; + $pause->{mods} = \@all; +} + +sub giveup_comaint { + my $c = shift; + $c->_share_remome(@_); + $c->_prepare_dist_package_mapping; +} + +sub _share_remome { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + my $u = $c->active_user_record; + my $db = $mgr->connect; + + my $all_mods = $c->all_only_cmods($u); + + if ( + $req->param("SUBMIT_pause99_share_perms_remome") + ) { + eval { + my(@selmods); + if (@selmods = @{$req->every_param("pause99_share_perms_remome_m")} + ) { + local($db->{RaiseError}) = 0; + my $sth = $db->prepare("DELETE FROM perms WHERE package=? AND userid=?"); + + my @results; + for my $selmod (@selmods) { + die PAUSE::Web::Exception + ->new(ERROR => "You do not seem to be co-maintainer of $selmod") + unless exists $all_mods->{$selmod}; + my $ret = $sth->execute($selmod,$u->{userid}); + my $err = ""; + $err = $db->errstr unless defined $ret; + $ret ||= ""; + warn "DEBUG: selmod[$selmod]ret[$ret]err[$err]"; + if ($ret) { + push @results, { + user => $u->{userid}, + mod => $selmod, + }; + delete $all_mods->{$selmod}; + } else { + push @results, { + user => $u->{userid}, + mod => $selmod, + error => $err, + }; + } + } + $pause->{results} = \@results; + } + }; + if ($@) { + $pause->{error} = $@->{ERROR}; + } + } + + my @all_mods = sort keys %$all_mods; + $pause->{mods} = \@all_mods; + + if (@all_mods == 1) { + $req->param("pause99_share_perms_remome_m" => $all_mods[0]); + } +} + +sub all_pmods_not_mmods { + my ($c, $u) = @_; + my $mgr = $c->app->pause; + my $db = $mgr->connect; + my(%all_mods); + my $sth2 = $db->prepare(qq{SELECT package + FROM primeur + WHERE userid=?}); + $sth2->execute($u->{userid}); + while (my($id) = $mgr->fetchrow($sth2, "fetchrow_array")) { + $all_mods{$id} = undef; + } + $sth2->finish; + \%all_mods; +} + +sub all_cmods { + my ($c, $u) = @_; + my $mgr = $c->app->pause; + my $db = $mgr->connect; + my(%all_mods); + my $sth2 = $db->prepare(qq{SELECT perms.package, primeur.userid + FROM perms LEFT JOIN primeur + ON perms.package = primeur.package + WHERE perms.userid=?}); + $sth2->execute($u->{userid}); + while (my($id, $owner) = $mgr->fetchrow($sth2, "fetchrow_array")) { + $all_mods{$id} = $owner; + } + $sth2->finish; + \%all_mods; +} + +sub all_pmods { + my ($c, $u) = @_; + my $mgr = $c->app->pause; + my $db = $mgr->connect; + my(%all_mods); + my $sth2 = $db->prepare(qq{SELECT package + FROM primeur + WHERE userid=?}); + $sth2->execute($u->{userid}); + while (my($id) = $mgr->fetchrow($sth2, "fetchrow_array")) { + $all_mods{$id} = undef; + } + $sth2->finish; + \%all_mods; +} + +sub all_only_cmods { + my($c,$u) = @_; + my $all_pmods = $c->all_pmods($u); + my $all_mods = $c->all_cmods($u); + + for my $k (keys %$all_pmods) { + delete $all_mods->{$k}; + } + $all_mods; +} + +sub all_comaints { + my ($c, $all_mods, $u) = @_; + my $mgr = $c->app->pause; + my $result = {}; + my $db = $mgr->connect; + my $or = join " OR\n", map { "package='$_'" } keys %$all_mods; + my $sth2 = $db->prepare(qq{SELECT package, userid + FROM perms + WHERE userid <> '$u->{userid}' AND ( $or )}); + $sth2->execute; + while (my($p,$i) = $mgr->fetchrow($sth2,"fetchrow_array")) { + $result->{"$p -- $i"} = undef; + warn "p[$p]i[$i]"; + } + return $result; +} + +sub _prepare_dist_package_mapping { + my ($c, $packages) = @_; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $db = $mgr->connect; + $packages //= [@{$pause->{mods} // []}]; + + my %map; + while(my @part = splice @$packages, 0, 500) { + my $placeholders = substr "?," x @part, 0, -1; + my $sth = $db->prepare("SELECT dist, package FROM packages WHERE package IN ($placeholders)"); + $sth->execute(@part); + while(my ($dist, $package) = $sth->fetchrow_array) { + $map{$package} = $dist; + } + } + $pause->{dist_for_package} = \%map; +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Controller/User/Uri.pm b/lib/pause_2025/PAUSE/Web/Controller/User/Uri.pm new file mode 100644 index 000000000..7f5169e29 --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Controller/User/Uri.pm @@ -0,0 +1,280 @@ +package PAUSE::Web::Controller::User::Uri; + +use Mojo::Base "Mojolicious::Controller"; +use Mojo::ByteStream; +use Mojo::URL; +use File::pushd; + +sub add { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + + $PAUSE::Config->{INCOMING_LOC} =~ s|/$||; + + my $u = $c->active_user_record; + die PAUSE::Web::Exception + ->new(ERROR => + "Unidentified error happened, please write to the PAUSE admins + at $PAUSE::Config->{ADMIN} and help them identifying what's going on. Thanks!") + unless $u->{userid}; + + my($tryupload) = 1; # everyone supports multipart now + my($uri); + my $userhome = PAUSE::user2dir($u->{userid}); + + if ($req->param("SUBMIT_pause99_add_uri_HTTPUPLOAD") + || $req->param("SUBMIT_pause99_add_uri_httpupload")) { + my $upl = $req->upload('pause99_add_uri_httpupload'); + unless ($upl->size) { + warn "Warning: maybe they hit RETURN, no upload size, not doing HTTPUPLOAD"; + $req->param("SUBMIT_pause99_add_uri_HTTPUPLOAD",""); + $req->param("SUBMIT_pause99_add_uri_httpupload",""); + } + } + if (! $req->param("SUBMIT_pause99_add_uri_HTTPUPLOAD") + &&! $req->param("SUBMIT_pause99_add_uri_httpupload") + &&! $req->param("SUBMIT_pause99_add_uri_uri") + &&! $req->param("SUBMIT_pause99_add_uri_upload") + ) { + # no submit button + if ($req->param("pause99_add_uri_uri")) { + $req->param("SUBMIT_pause99_add_uri_uri", "2ndguess"); + } elsif ($req->param("pause99_add_uri_upload")) { + $req->param("SUBMIT_pause99_add_uri_upload", "2ndguess"); + } + } + + my $didit = 0; + my $now = time; + if ( + $req->param("SUBMIT_pause99_add_uri_httpupload") || # from 990806 + $req->param("SUBMIT_pause99_add_uri_HTTPUPLOAD") + ) { + { # $pause->{UseModuleSet} eq "ApReq" + my $upl; + if ( + $upl = $req->upload("pause99_add_uri_httpupload") or # from 990806 + $upl = $req->upload("HTTPUPLOAD") + ) { + if ($upl->size) { + 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; + $req->param("pause99_add_uri_httpupload",$filename); + $pause->{upload_is_renamed} = { + from => $dv->stringify($upl->filename), + to => $dv->stringify($filename), + }; + } + } else { + die PAUSE::Web::Exception + ->new(ERROR => + "uploaded file was zero sized"); + } + } else { + die PAUSE::Web::Exception + ->new(ERROR => + "Could not create an upload object. DEBUG: upl[$upl]"); + } + } + } elsif ( $req->param("SUBMIT_pause99_add_uri_uri") ) { + $uri = $req->param("pause99_add_uri_uri"); + $req->param("pause99_add_uri_httpupload",""); # I saw spurious + # nonsense in the + # field that broke + # XHTML + } elsif ( $req->param("SUBMIT_pause99_add_uri_upload") ) { + $uri = $req->param("pause99_add_uri_upload"); + $req->param("pause99_add_uri_httpupload",""); # I saw spurious + # nonsense in the + # field that broke + # XHTML + } + my $server = $PAUSE::Config->{SERVER_NAME} || $req->url->to_abs->host; + my $dbh = $mgr->connect; + + $pause->{uploaded_uri} = $uri; + if ($uri) { + $c->add_uri_continue_with_uri($uri,\$didit); + } + + if ($tryupload) { + $pause->{tryupload} = $tryupload; + my $subdirs = $c->_find_subdirs($u); + $pause->{subdirs} = $subdirs if $subdirs; + } + + # HTTP UPLOAD + + if ($tryupload) { + $c->need_form_data(1); + $c->res->headers->accept("*"); + } + + # via FTP GET + + warn "DEBUG: UPLOAD[$PAUSE::Config->{UPLOAD}]"; + + # END OF UPLOAD OPTIONS +} + +sub _find_subdirs { + my ($c, $u) = @_; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + + my $userhome = PAUSE::user2dir($u->{userid}); + $pause->{userhome} = $userhome; + + my $pushd = eval { pushd("$PAUSE::Config->{MLROOT}/$userhome") } or return; + warn "DEBUG: MLROOT[$PAUSE::Config->{MLROOT}] userhome[$userhome] E:M:V[$ExtUtils::Manifest::VERSION]"; + + my %files = $c->manifind; + my %seen; + my @dirs = sort grep !$seen{$_}++, grep s|(.+)/[^/]+|$1|, keys %files; + return unless @dirs; + unshift @dirs, "."; + return \@dirs; +} + +sub add_uri_continue_with_uri { + my ($c, $uri, $didit) = @_; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + my $u = $c->active_user_record; + my $userhome = PAUSE::user2dir($u->{userid}); + 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("pause99_add_uri_subdirtext") ) { + $subdir = $req->param("pause99_add_uri_subdirtext"); + } elsif ( $req->param("pause99_add_uri_subdirscrl") ) { + $subdir = $req->param("pause99_add_uri_subdirscrl"); + } + + 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, $u->{userid}, $filename, $uri, $pause->{User}{userid}, $now, + $is_perl6 + ); + #display query + local($dbh->{RaiseError}) = 0; + if ($dbh->do($query, undef, @query_params)) { + $$didit = 1; + $pause->{query_succeeded} = 1; + + my $usrdir = "https://$server/pub/PAUSE/authors/id/$userhome"; + my $tailurl = "https://$server/pause/authenquery?ACTION=tail_logfile" . + "&pause99_tail_logfile_1=5000"; + + $pause->{usrdir} = $usrdir; + $pause->{tailurl} = $tailurl; + } else { + my $errmsg = $dbh->errstr; + $pause->{errmsg} = $errmsg; + $c->res->code(406); + + if ($errmsg =~ /non\s+unique\s+key|Duplicate/i) { + $pause->{duplicate} = 1; + $c->res->code(409); + my $sth = $dbh->prepare("SELECT * FROM uris WHERE uriid=?"); + $sth->execute($uriid); + my $rec = $mgr->fetchrow($sth, "fetchrow_hashref"); + for my $k (qw(changed dgot dverified)) { + if ($rec->{$k}) { + $rec->{$k} .= sprintf " [%s UTC]", scalar gmtime $rec->{$k}; + } + } + $pause->{rec} = $rec; + } + } + } +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Exception.pm b/lib/pause_2025/PAUSE/Web/Exception.pm new file mode 100644 index 000000000..e65fbf9d7 --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Exception.pm @@ -0,0 +1,9 @@ +package PAUSE::Web::Exception; + +use Mojo::Base -base; +use overload + '""' => sub {$_[0]->{ERROR} ? $_[0]->{ERROR} : $_[0]->{HTTP_STATUS} ? $_[0]->{HTTP_STATUS} : ""}, +; + + +1; diff --git a/lib/pause_2025/PAUSE/Web/Middleware/Auth/Basic.pm b/lib/pause_2025/PAUSE/Web/Middleware/Auth/Basic.pm new file mode 100644 index 000000000..282847fa2 --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Middleware/Auth/Basic.pm @@ -0,0 +1,190 @@ +package PAUSE::Web::Middleware::Auth::Basic; + +use Mojo::Base "Plack::Middleware"; +use MIME::Base64; +use HTTP::Status qw/:constants/; +use PAUSE (); +use PAUSE::Crypt; +use Plack::Request; +use DBI; +use Carp (); + +has "context"; + +sub call { + my ($self, $env) = @_; + + local $SIG{__WARN__} = sub { + my $message = shift; + chomp $message; + Log::Dispatch::Config->instance->log( + level => 'warn', + message => $message, + ); + }; + + warn "before authentication"; + my $res = eval { $self->authenticate($env) }; + if ($@) { + Log::Dispatch::Config->instance->log( + level => 'error', + message => "AUTH ERROR: $@", + ); + } + + return $res->finalize if ref $res; + return $self->unauthorized($env) unless $res == HTTP_OK; + return $self->app->($env); +} + +sub unauthorized { + my ($self, $env) = @_; + my $body = delete $env->{"pause.auth_error"} || 'Authorization required'; + return [ + 401, + [ 'Content-Type' => 'text/plain', + 'Content-Length' => length $body, + 'WWW-Authenticate' => 'Basic realm="PAUSE"' ], + [ $body ], + ]; +} + + +sub authenticate { + my ($self, $env) = @_; + + my $req = Plack::Request->new($env); + + my $cookie; + my $uri = $req->path || ""; + $uri = "/pause".$uri unless $uri =~ m!/pause/!; # add mount point + my $args = $req->uri->query || ""; + warn "WATCH: uri[$uri]args[$args]"; + if ($cookie = $req->headers->header('Cookie')) { + if ( $cookie =~ /logout/ ) { + warn "WATCH: cookie[$cookie]"; + my $res = $req->new_response(HTTP_UNAUTHORIZED); + $res->cookies->{logout} = { + value => '', + path => $uri, + expires => "Sat, 01-Oct-1974 00:00:00 UTC", + }; + return $res; + } + } + warn "WATCH: uri[$uri]args[$args]"; + if ($args) { + my $logout; + if ( my $logout = $req->query_parameters->get('logout') ) { + warn "WATCH: logout[$logout]"; + if ($logout =~ /^1/) { + my $res = $req->new_response(HTTP_MOVED_PERMANENTLY); + $res->cookies->{logout} = { + value => '', + path => $uri, + expires => "Sat, 01-Oct-2027 00:00:00 UTC", + }; + $res->headers->header("Location",$uri); + return $res; + } elsif ($logout =~ /^2/) { # badname + my $redir = $req->base; + $redir->path($req->uri->path); + $redir->userinfo('baduser:badpass'); + warn "redir[$redir]"; + my $res = $req->new_response(HTTP_MOVED_PERMANENTLY); + $res->headers->header("Location",$redir); + return $res; + } elsif ($logout =~ /^3/) { # cancelnote + return HTTP_UNAUTHORIZED; + } + } + } + + warn "WATCH: uri[$uri]args[$args]"; + my $auth = $env->{HTTP_AUTHORIZATION} or return HTTP_UNAUTHORIZED; + return HTTP_UNAUTHORIZED unless $auth =~ /^Basic (.*)$/i; #decline if not Basic + my $basic = $1; + my($user_sent, $sent_pw) = split /:/, (MIME::Base64::decode($basic) || ":"), 2; + + warn "WATCH: uri[$uri]args[$args]"; + my $attr = { + data_source => $PAUSE::Config->{AUTHEN_DATA_SOURCE_NAME}, + username => $PAUSE::Config->{AUTHEN_DATA_SOURCE_USER}, + password => $PAUSE::Config->{AUTHEN_DATA_SOURCE_PW}, + pwd_table => $PAUSE::Config->{AUTHEN_USER_TABLE}, + uid_field => $PAUSE::Config->{AUTHEN_USER_FLD}, + pwd_field => $PAUSE::Config->{AUTHEN_PASSWORD_FLD}, + }; + + my $dbh; + warn "DEBUG: attr.data_source[$attr->{data_source}]"; + unless ($dbh = DBI->connect($attr->{data_source}, + $attr->{username}, + $attr->{password})) { + Log::Dispatch::Config->instance->log(level => 'error', message => " db connect error with $attr->{data_source} ".$req->path); + my $redir = $req->path; + $redir =~ s/authen//; + delete $env->{REMOTE_USER}; + return $req->new_response(HTTP_INTERNAL_SERVER_ERROR, undef, $redir); + } + + # generate statement + my $user_record; + my @try_user = $user_sent; + push @try_user, uc $user_sent if $user_sent ne uc $user_sent; + + my $statement = qq{SELECT * FROM $attr->{pwd_table} + WHERE $attr->{uid_field}=?}; + # prepare statement + my $sth; + unless ($sth = $dbh->prepare($statement)) { + Log::Dispatch::Config->instance->log(level => 'error', message => "can not prepare statement: $DBI::errstr". $req->path); + $sth->finish; + $dbh->disconnect; + return $req->new_response(HTTP_INTERNAL_SERVER_ERROR); + } + for my $user (@try_user){ + unless ($sth->execute($user)) { + Log::Dispatch::Config->instance->log(level => 'error', message => " can not execute statement: $DBI::errstr" . $req->path); + $sth->finish; + $dbh->disconnect; + return $req->new_response(HTTP_INTERNAL_SERVER_ERROR); + } + + if ($sth->rows == 1){ + $user_record = $self->context->fetchrow($sth, "fetchrow_hashref"); + $env->{REMOTE_USER} = $user; + last; + } + } + $sth->finish; + + # delete not to be carried around + my $crypt_pw = delete $user_record->{$attr->{pwd_field}}; + if ($crypt_pw) { + if (PAUSE::Crypt::password_verify($sent_pw, $crypt_pw)) { + PAUSE::Crypt::maybe_upgrade_stored_hash({ + password => $sent_pw, + old_hash => $crypt_pw, + dbh => $dbh, + username => $user_record->{user}, + }); + $env->{"pause.user_secrets"} = $user_record; + $dbh->do + ("UPDATE usertable SET lastvisit=NOW() where user=?", + +{}, + $user_record->{user}, + ); + $dbh->disconnect; + return HTTP_OK; + } else { + warn sprintf "failed login: user[%s]uri[%s]auth_required[%d]", + $user_record->{user}, $req->path, HTTP_UNAUTHORIZED; + } + } + + $dbh->disconnect; + return HTTP_UNAUTHORIZED; +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Plugin/ConfigPerRequest.pm b/lib/pause_2025/PAUSE/Web/Plugin/ConfigPerRequest.pm new file mode 100644 index 000000000..64721fdc7 --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Plugin/ConfigPerRequest.pm @@ -0,0 +1,327 @@ +package PAUSE::Web::Plugin::ConfigPerRequest; + +# XXX: Some of these can be moved into root#check etc, +# and some can be removed now + +use Mojo::Base "Mojolicious::Plugin"; +use Sys::Hostname; + +sub register { + my ($self, $app, $conf) = @_; + $app->hook(before_dispatch => \&_before_dispatch); + $app->helper(need_form_data => \&_need_form_data); +} + +sub _before_dispatch { + my $c = shift; + + $c->stash(".pause" => {}) unless $c->stash(".pause"); + + _is_ssl($c); + _retrieve_user($c); + _set_allowed_actions($c); +} + +sub _is_ssl { + my $c = shift; + my $pause = $c->stash(".pause"); + if ($c->req->url->to_abs->scheme eq "https") { + $pause->{is_ssl} = 1; + } elsif ($PAUSE::Config->{TRUST_IS_SSL_HEADER}) { + my $header = $c->req->headers->header("X-pause-is-SSL") || 0; + $pause->{is_ssl} = !!$header; + } +} + +sub _need_form_data { + my $c = shift; + my $pause = $c->stash(".pause"); + if (@_) { + $pause->{need_form_data} = shift; + } + $pause->{need_form_data}; +} + + +sub _retrieve_user { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + + my $user = $c->req->env->{REMOTE_USER} or return; + + # 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. Many users with an insecure password have got their password reset recently because of an incident on perlmonks.org. 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; + + $sql = qq{SELECT * + FROM grouptable + WHERE user=?}; + $sth = $dbh2->prepare($sql); + if ($sth->execute($user)) { + $pause->{UserGroups} = {}; + while (my $rec = $mgr->fetchrow($sth, "fetchrow_hashref")) { + $pause->{UserGroups}{$rec->{ugroup}} = undef; + } + } else { + die PAUSE::Web::Exception->new(ERROR => $dbh2->errstr); + } + $sth->finish; + + delete $pause->{UserGroups}{mlrepr}; # virtual group, disallow in the table + $sql = qq{SELECT * + FROM list2user + WHERE userid=?}; + $sth = $dbh->prepare($sql); + $sth->execute($user) or die PAUSE::Web::Exception->new(ERROR => $dbh->errstr); + if ($sth->rows > 0) { + $pause->{UserGroups}{mlrepr} = undef; # is a virtual group + my %mlrepr; + while (my $rec = $mgr->fetchrow($sth, "fetchrow_hashref")) { + $mlrepr{$rec->{maillistid}} = undef; + } + $pause->{IsMailinglistRepresentative} = \%mlrepr; + } + + $pause->{UserSecrets} = $c->req->env->{"pause.user_secrets"}; + if ( $pause->{UserSecrets}{forcechange} ) { + $pause->{Action} = "change_passwd"; # ueberschreiben + $c->req->param(ACTION => "change_passwd"); # faelschen + } +} + + +sub _set_allowed_actions { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + + my ($param, @allow_submit, %allow_action); + + # What is allowed here is allowed to anybody + @allow_action{ $mgr->config->action_names_for('public') } = (); + + @allow_submit = ( + "request_id", + ); + + my $userid = ''; + if ($pause->{User} && $pause->{User}{userid} && $pause->{User}{userid} ne "-") { + $userid = $pause->{User}{userid}; + + # warn "userid[$pause->{User}{userid}]"; + + # All authenticated Users + for my $command ( $mgr->config->action_names_for('user') ) { + $allow_action{$command} = undef; + push @allow_submit, $command; + } + + # Only Mailinglist Representatives + if (exists $pause->{UserGroups}{mlrepr} or exists $pause->{UserGroups}{admin}) { + for my $command ( $mgr->config->action_names_for('mlrepr') ) { + $allow_action{$command} = undef; + push @allow_submit, $command; + } + } + + # Postmaster or admin + if ( + exists $pause->{UserGroups}{admin} + or + exists $pause->{UserGroups}{postmaster} + ) { + for my $command ( + "email_for_admin", + ) { + $allow_action{$command} = undef; + push @allow_submit, $command; + } + } + + # Only Admins + if (exists $pause->{UserGroups}{admin}) { + # warn "We have an admin here"; + for my $command ( $mgr->config->action_names_for('admin') ) { + $allow_action{$command} = undef; + push @allow_submit, $command; + } + } + + } elsif ($param = $req->param("ABRA")) { + + # TUT: if they sent ABRA, the only thing we let them do is change + # their password. The parameter consists of username-dot-token. + my($user, $passwd) = $param =~ m|(.*?)\.(.*)|; # + + # We allow changing of the password with this password. We leave + # everything else untouched + + my $dbh; + $dbh = $mgr->authen_connect; + my $sql = sprintf qq{DELETE FROM abrakadabra + WHERE NOW() > expires }; + $dbh->do($sql); + $sql = qq{SELECT * + FROM abrakadabra + WHERE user=? AND chpasswd=?}; + my $sth = $dbh->prepare($sql); + if ( $sth->execute($user, $passwd) and $sth->rows ) { + # TUT: in the keys of %allow_action we store the methods that are + # allowed in this request. @allow_submit does something similar. + $allow_action{"change_passwd"} = undef; + push @allow_submit, "change_passwd"; + + # TUT: by setting $pause->{User}{userid}, we can let change_passwd + # know who we are dealing with + $pause->{User}{userid} = $user; + $userid = $user; + + # TUT: Let's pretend they requested change_passwd. I guess, if we + # would drop that line, it would still work, but I like redundant + # coding in such cases + $param = $req->param("ACTION", "change_passwd"); # override + + } else { + die PAUSE::Web::Exception->new(ERROR => "You tried to authenticate the +parameter ABRA=$param, but the database doesn't know about this token.", HTTP_STATUS => 401); + } + $allow_action{"mailpw"} = undef; + push @allow_submit, "mailpw"; + + } else { + + # warn "unauthorized access (but OK)"; + $allow_action{"mailpw"} = undef; + push @allow_submit, "mailpw"; + + } + $pause->{allow_action} = [ sort { $a cmp $b } keys %allow_action ]; + # warn "allowaction[@{$pause->{allow_action}}]"; + # warn "allowsubmit[@allow_submit]"; + + $param = $req->param("ACTION"); + # warn "ACTION-param[$param]req[$req]"; + if ($param) { + if (exists $allow_action{$param}) { + $pause->{Action} = $param; + } else { + warn "$userid tried disallowed action: $param"; + die PAUSE::Web::Exception->new(ERROR => "Forbidden", HTTP_STATUS => 403); + } + } else { + # ...they might ask for it in a submit button + ACTION: for my $action (@allow_submit) { + + # warn "DEBUG: action[$action]"; + + # we inherited from a different project: One submitbutton on a page + if ( + $param = $req->param("pause99_$action\_sub") + ) { + # warn "action[$action]"; + $pause->{Action} = $action; + last ACTION; + } + + # Also inherited: One submitbutton but also only one textfield, + # so that RETURN on the textfield submits the form + if ( + $param = $req->param("pause99_$action\_1") + ) { + $req->param("pause99_$action\_sub", $param); # why? + $pause->{Action} = $action; + last ACTION; + } + + # I had intended that parameters matching /_sub.*/ are only used + # in cases where RETURN might be used instead of SUBMIT. Then I + # erroneously used "pause99_add_uri_subdirtext" + + my (@partial) = grep /^pause99_\Q$action\E_/, @{$req->params->names}; + PART: for my $partial (@partial) { + $req->param("pause99_$action\_sub", $partial); # why not $pause->{action_comment}? + $pause->{Action} = $action; + last PART; + } + } + } + my $action = $pause->{Action}; + if (!$action || $req->param('lsw')) { # let submit win + + # the let submit win parameter was introduced when I realized that + # submit should always win but was afraid that it might break + # something when we suddenly let submit win in all cases. So new + # forms should always specify lsw=1 so we can migrate to making it + # the default some day. + + # New and more generic than the inherited ones above: several submit buttons + my @params = grep s/^(weak)?SUBMIT_pause99_//i, @{$req->params->names}; + for my $p (@params) { + # warn "p[$p]"; + for my $a (@allow_submit) { + if ( substr($p,0,length($a)) eq $a ) { + $pause->{Action} = $a; + last; + } + } + last if $pause->{Action}; + } + } + $action = $pause->{Action}; + if ($action && !exists $allow_action{$action}) { + warn "$userid tried disallowed action: $action"; + die PAUSE::Web::Exception->new(ERROR => "Forbidden", HTTP_STATUS => 403); + } + # warn "action[$action]"; +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Plugin/Delegate.pm b/lib/pause_2025/PAUSE/Web/Plugin/Delegate.pm new file mode 100644 index 000000000..ca38e2241 --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Plugin/Delegate.pm @@ -0,0 +1,23 @@ +package PAUSE::Web::Plugin::Delegate; + +# Mojolicious doesn't have this feature with good intention +# but we need this anyway + +use Mojo::Base "Mojolicious::Plugin"; + +sub register { + my ($self, $app, $conf) = @_; + $app->helper(delegate => \&_delegate); +} + +sub _delegate { + my ($c, $action) = @_; + my $routes = $c->app->routes; + my $route = $routes->lookup($action) or die "no route for $action"; + my $to = $route->to; + push @{$c->match->stack}, $to; + $routes->_controller($c, $to); + return; +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Plugin/EditUtils.pm b/lib/pause_2025/PAUSE/Web/Plugin/EditUtils.pm new file mode 100644 index 000000000..222e3eef3 --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Plugin/EditUtils.pm @@ -0,0 +1,37 @@ +package PAUSE::Web::Plugin::EditUtils; + +# XXX: Should be removed eventually + +use Mojo::Base "Mojolicious::Plugin"; +use ExtUtils::Manifest; +use Cwd (); + +sub register { + my ($self, $app, $conf) = @_; + + $app->helper(manifind => \&_manifind); +} + +sub _manifind { + my $c = shift; + + my $cwd = Cwd::cwd(); + warn "cwd[$cwd]"; + my %files = %{ExtUtils::Manifest::manifind()}; + if (keys %files == 1 && exists $files{""} && $files{""} eq "") { + warn "ALERT: BUG in MANIFIND, falling back to zsh !!!"; + + # This bug was caused by libc upgrade: perl and apache were + # compiled with 2.1.3; upgrading to 2.2.5 and/or later + # recompilation of apache has caused readdir() to return a list of + # empty strings. + + open my $ls, "zsh -c 'ls **/*(.)' |" or die; + %files = map { chomp; $_ => "" } <$ls>; + close $ls; + } + + %files; +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Plugin/FixAction.pm b/lib/pause_2025/PAUSE/Web/Plugin/FixAction.pm new file mode 100644 index 000000000..156dd0dca --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Plugin/FixAction.pm @@ -0,0 +1,70 @@ +package PAUSE::Web::Plugin::FixAction; + +use Mojo::Base "Mojolicious::Plugin"; +use HTTP::Status qw/:constants/; + +# Set hook to convert old ACTION params to router paths +sub register { + my ($self, $app, $conf) = @_; + + $app->hook(before_dispatch => \&_fix); +} + +sub _fix { + my $c = shift; + + _fixup($c); # does what fixup handler did + return if $c->res->is_finished; + + my $action = $c->req->param("ACTION"); + + # Ignore if there's no ACTION or ACTION overrides root + return if !$action or $action eq "root"; + my $path = $c->req->url->path; + $c->req->url->path("$path/$action"); + $c->stash(".pause")->{Action} = $action; +} + + + +=comment + +All Location below /pause share this FixupHandler. All we want to +achieve is that these mappings are in effect: + + /pause redir=> /pause/query CASE 1 + /pause/ trans=> /pause/query CASE 2 + /pause/query OK CASE 3 + /pause/authenquery OK CASE 3 + +I have the suspicion that this would be easier with a completely +different approach, but as it works, I do not investigate further now. +=cut + +sub _fixup { + my $c = shift; + my $req = $c->req; + + my $uri = $req->env->{REQUEST_URI}; + my $location = '/pause'; # $r->location; + + # warn "uri[$uri]location[$location] (Question was, does location ever match /query/?)"; + if ($uri eq $location or $uri eq "$location/") { + + # CASE 1/2 + + my $redir = $req->url->base; + my $is_ssl = $req->headers->header("X-pause-is-SSL") || 0; + if ($is_ssl) { + $redir->scheme("https"); + } + $redir->path("$location/query"); + $c->res->code(HTTP_MOVED_PERMANENTLY); + $c->res->headers->header("Location",$redir); + # warn "redir[$redir]"; + return $c->res->finish; + } + return unless $uri eq "$location/"; +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Plugin/GetActiveUserRecord.pm b/lib/pause_2025/PAUSE/Web/Plugin/GetActiveUserRecord.pm new file mode 100644 index 000000000..73c4a5fab --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Plugin/GetActiveUserRecord.pm @@ -0,0 +1,181 @@ +package PAUSE::Web::Plugin::GetActiveUserRecord; + +use Mojo::Base "Mojolicious::Plugin"; + +sub register { + my ($self, $app, $conf) = @_; + $app->helper(active_user_record => \&_get); +} + + +sub _get { + my ($c, $hidden_user, $opt) = @_; + $opt ||= {}; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + + my $hidden_user_ok = $opt->{hidden_user_ok} // ''; # caller is absolutely + # sure that hidden_user + # is authenticated or + # harmless (mailpw) + + my $req = $c->req; + if ($hidden_user) { + Carp::cluck("hidden_user[$hidden_user] passed in as argument with hidden_user_ok[$hidden_user_ok]"); + } else { + my $hiddenname_para = $req->param('HIDDENNAME') || ""; + $hidden_user ||= $hiddenname_para; + warn "DEBUG: hidden_user[$hidden_user] after hiddenname parameter[$hiddenname_para]"; + } + + { + my $uc_hidden_user = uc $hidden_user; + unless ($uc_hidden_user eq $hidden_user) { + $c->app->pause->log({level => 'warn', message => "Warning: Had to uc the hidden_user $hidden_user" }); + $hidden_user = $uc_hidden_user; + } + } + + my $user = {}; + my $userid = $pause->{User}{userid} // ''; + $mgr->log({level => 'info', message => sprintf("Watch: mgr/User/userid[%s]hidden_user[%s]mgr/UserGroups[%s]caller[%s]where[%s]", + $userid, + $hidden_user, + join(":", keys %{$pause->{UserGroups} || {}}), + join(":", caller), + __FILE__.":".__LINE__, + )}); + + if ( + $hidden_user + && + $hidden_user ne $userid + ){ + # Imagine, MSERGEANT wants to pass Win32::ASP to WNODOM + + my $dbh1 = $mgr->connect; + my $sth1 = $dbh1->prepare("SELECT * FROM users WHERE userid=?"); + $sth1->execute($hidden_user); + unless ($sth1->rows){ + Carp::cluck( + sprintf( + "ALERT: hidden_user[%s] rows_as_s[%s] rows_as_d[%d]", + $hidden_user, + $sth1->rows, + $sth1->rows, + )); + die PAUSE::Web::Exception->new(ERROR => "Unidentified error happened, please write to the PAUSE admin at $PAUSE::Config->{ADMIN} and help him identifying what's going on. Thanks!"); + } + my $hiddenuser_h1 = $mgr->fetchrow($sth1, "fetchrow_hashref"); + + $sth1->finish; + + # $hiddenuser_h1 should now be WNODOM's record + + if ($opt->{checkonly}) { + # since we have checkonly this is the MSERGEANT case + return $hiddenuser_h1; + } elsif ($hiddenuser_h1->{isa_list}) { + + # This is NOT the MSERGEANT case + + if ( + exists $pause->{IsMailinglistRepresentative}{$hiddenuser_h1->{userid}} + || + ( + $pause->{UserGroups} + && + exists $pause->{UserGroups}{admin} + ) + ){ + # OK, we believe you come with good intentions, but we check + # if this action makes sense because we fear for the integrity + # of the database, no matter if you are user or admin. + if ( + grep { $_ eq $pause->{Action} } $mgr->config->allow_mlrepr_takeover + ) { + warn "Watch: privilege escalation"; + $user = $hiddenuser_h1; # no secrets for a mailinglist + } else { + die PAUSE::Web::Exception + ->new(ERROR => + sprintf( + qq[Action '%s' seems not to be supported + for a mailing list], + $pause->{Action}, + ) + ); + } + } + } elsif ( + $hidden_user_ok + || + $pause->{UserGroups} + && + exists $pause->{UserGroups}{admin} + ) { + + # This isn't the MSERGEANT case either, must be admin + # The case of hidden_user_ok is when they forgot password + + my $dbh2 = $mgr->authen_connect; + my $sth2 = $dbh2->prepare("SELECT secretemail, lastvisit + FROM $PAUSE::Config->{AUTHEN_USER_TABLE} + WHERE $PAUSE::Config->{AUTHEN_USER_FLD}=?"); + $sth2->execute($hidden_user); + my $hiddenuser_h2 = $mgr->fetchrow($sth2, "fetchrow_hashref"); + $sth2->finish; + for my $h ($hiddenuser_h1, $hiddenuser_h2) { + for my $k (keys %$h) { + $user->{$k} = $h->{$k}; + } + } + } elsif (0) { + return $user; + } else { + # So here is the MSERGEANT case, most probably + # But the ordinary record must do. No secret email stuff here, no passwords + # 2009-06-15 akoenig : adamk reports a massive security hole + require YAML::Syck; + Carp::confess + ( + YAML::Syck::Dump({ hiddenuser => $hiddenuser_h1, + error => "looks like unwanted privilege escalation", + user => $user, + })); + # maybe we should just return the current user here? or we + # should check the action? Don't think so, filling HiddenUser + # member might be OK but returning the other user? Unlikely. + } + } else { + unless ($pause->{User}{fullname}) { + # this guy most probably came via ABRA and we should fill some slots + + my $dbh1 = $mgr->connect; + my $sth1 = $dbh1->prepare("SELECT * FROM users WHERE userid=?"); + $sth1->execute($pause->{User}{userid}); + die PAUSE::Web::Exception + ->new(ERROR => + "Unidentified error happened, please write to the PAUSE admin + at $PAUSE::Config->{ADMIN} and help them identify what's going on. Thanks!") + unless $sth1->rows; + + $pause->{User} = $mgr->fetchrow($sth1, "fetchrow_hashref"); + $sth1->finish; + + my $dbh2 = $mgr->authen_connect; + my $sth2 = $dbh2->prepare("SELECT secretemail + FROM $PAUSE::Config->{AUTHEN_USER_TABLE} + WHERE $PAUSE::Config->{AUTHEN_USER_FLD}=?"); + $sth2->execute($pause->{User}{userid}); + my $row = $mgr->fetchrow($sth2, "fetchrow_hashref"); + $pause->{User}{secretemail} = $row->{secretemail}; + $sth2->finish; + } + %$user = (%{$pause->{User}||{}}, %{$pause->{UserSecrets}||{}}); + } + $pause->{HiddenUser} = $user; + $user; +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Plugin/GetUserMeta.pm b/lib/pause_2025/PAUSE/Web/Plugin/GetUserMeta.pm new file mode 100644 index 000000000..14d190f4e --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Plugin/GetUserMeta.pm @@ -0,0 +1,184 @@ +package PAUSE::Web::Plugin::GetUserMeta; + +use Mojo::Base "Mojolicious::Plugin"; + +sub register { + my ($self, $app, $conf) = @_; + $app->helper(user_meta => \&_get); +} + +=pod + +In user_meta liegt noch der ganze Scheiss herum, mit dem ich die +unglaubliche Langsamkeit analysiert habe, die eintrat, als ich den +alten Algorithmus durch 5.8 habe durchlaufen lassen. + +Am Schluss (mit $sort_method="splitted") war 5.8 etwa gleich schnell +wie 5.6, aber die Trickserei ist etwas zu aufwendig fuer meinen +Geschmack. + +Also, der Fehler war, dass ich zuerst einen String zusammengebaut +habe, der UTF-8 enthalten konnte und uebermaessig lang war und dann +darueber im Sort-Algorithmus lc laufen liess. Jedes einzelne lc hat +etwas Zeit gekostet, da es im Sort-Algorithmus war, musste es 40000 +mal statt 2000 mal laufen. Soweit, so klar auf einen Blick: richtige +Loesung ist es, den String mit Hilfe des "translit" Feldes zo kurz zu +lassen, dass nur ASCII verbleibt, dann ein downgrade, dann lc, und +dann erst Sortieren. In einem zweiten Hash traegt man den +Display-String herum. + +Was bis heute ein Mysterium ist, ist die Frage, wieso das Einschalten +der Statistik, also ein hoher *zusaetzlicher* Aufwand, die Zeit auf +ein Sechstel biz Zehntel *gedrueckt* hat. Da muss etwas Schlimmes mit +$a und $b passieren. + +=cut + +sub _get { + my $c = shift; + my $mgr = $c->app->pause; + my $dbh = $mgr->connect; + my $sql = qq{SELECT userid, fullname, isa_list, asciiname + FROM users}; + my $sth = $dbh->prepare($sql); + $sth->execute; + my(%u,%labels); + # my $sort_method = "gogo"; + my $sort_method = "splitted"; + if (0) { # worked mechanically correct but slow with 5.7.3@16103. + # The slowness is not in the fetchrow but in the sort with + # lc below. At the time of the test $mgr->fetchrow turned + # on UTF-8 flag on everything, including pure ASCII. + + while (my @row = $mgr->fetchrow($sth, "fetchrow_array")) { + $u{$row[0]} = $row[2] ? "mailinglist $row[0]" : "$row[1] ($row[0])"; + } + + } elsif (0) { + + # here we are measuring where the time is spent and tuning up and + # down and experiencing strange effects. + + my $start = Time::HiRes::time(); + my %tlc; + while (my @row = $sth->fetchrow_array) { + if ($] > 5.007) { + # apparently it pays to only turn on UTF-8 flag if necessary + defined && /[^\000-\177]/ && Encode::_utf8_on($_) for @row; + } + $u{$row[0]} = $row[2] ? "mailinglist $row[0]" : + $row[3] ? "$row[3]=$row[1] ($row[0])" : "$row[1] ($row[0])"; + + if (0) { + # measuring lc() alone does not explain the slow sort. We see + # about 0.4 secs for lc() on all names when they all have the + # UTF-8 flag on, about 0.07 secs when only selected ones have + # the flag on. + next unless $row[1]; + my $tlcstart = Time::HiRes::time(); + $tlc{$row[1]} = lc $row[1]; + $tlc{$row[1]} = Time::HiRes::time() - $tlcstart; + } + } + # warn sprintf "TIME: fetchrow and lc on users: %7.4f", Time::HiRes::time()-$start; + my $top = 10; + for my $t (sort { $tlc{$b} <=> $tlc{$a} } keys %tlc) { + warn sprintf "%-43s: %9.7f\n", $t, $tlc{$t}; + last unless --$top; + } + } else { # splitted! + my $start = Time::HiRes::time(); + while (my @row = $sth->fetchrow_array) { + if ($] > 5.007) { + # apparently it pays to only turn on UTF-8 flag if necessary + defined && /[^\000-\177]/ && Encode::_utf8_on($_) for @row; + } + my $disp = $row[2] ? + "$row[0] (mailinglist)" : + $row[3] ? + "$row[0]:$row[3]=$row[1]" : + "$row[0]:$row[1]"; + substr($disp, 52) = "..." if length($disp) > 55; + my($sort) = $disp =~ /^([\000-\177]+)/; + utf8::downgrade($sort) if $] > 5.007; + $u{$row[0]} = lc $sort; + $labels{$row[0]} = $disp; + } + warn sprintf "TIME: fetchrow and split on users: %7.4f", Time::HiRes::time()-$start; + } + my $start = Time::HiRes::time(); + our @tlcmark = (); + our $Collator; + if ($sort_method eq "U:C") { + require Unicode::Collate; + $Collator = Unicode::Collate->new(); + } + # use sort qw(_mergesort); + # use sort qw(_quicksort); + my @sorted = sort { + if (0) { + # Mysterium: the worst case was to have all names with UTF-8 + # flag, Sort_method="lc" and running no statistics. Turning on + # the statistics here reduced runtime from 77-133 to 12 secs. + # With only selected names having UTF-8 flag on we reach 10 secs + # without the statistics and 12 with it. BTW, mergesort counts + # 20885 comparisons, quicksort counts 23201. + push( + @tlcmark, + sprintf("%s -- %s: %9.7f", + $u{$a}, + $u{$b}, + Time::HiRes::time()) + ); + } + if (0) { + } elsif ($sort_method eq "lc") { + # we reach minimum of 10 secs here, better than 77-133 but still + # unacceptable. We seem to have to fight against two bugs: slow + # lc() always is one bug, extremely slow lc() when combined with + # sort is the other one. We must solve it as we did in metalist: + # maintain a sortdummy in the database and let the database sort + # on ascii. + lc($u{$a}) cmp lc($u{$b}); + } elsif ($sort_method eq "U:C") { + $Collator->cmp($a,$b); + # v0.10 completely bogus and 67 secs + } elsif ($sort_method eq "splitted") { + $u{$a} cmp $u{$b}; + } else { + # we reach 0.27 secs here with mergesort, 0.28 secs after we + # switched to quicksort. + $u{$a} cmp $u{$b}; + } + } keys %u; + warn sprintf "TIME: sort on users: %7.4f", Time::HiRes::time()-$start; + if (@tlcmark) { + warn "COMPARISONS: $#tlcmark"; + my($Ltlcmark) = $tlcmark[0] =~ /:\s([\d\.]+)/; + # warn "$Ltlcmark;$tlcmark[0]"; + my $Mdura = 0; + for my $t (1..$#tlcmark) { + my($tlcmark) = $tlcmark[$t] =~ /:\s([\d\.]+)/; + my $dura = $tlcmark - $Ltlcmark; + if ($dura > $Mdura) { + my($lterm) = $tlcmark[$t-1] =~ /(.*):/; + warn sprintf "%s: %9.7f\n", $lterm, $dura; + $Mdura = $dura; + } + $Ltlcmark = $tlcmark; + } + } + + return ( + userid => { + type => "scrolling_list", + args => { + 'values' => \@sorted, + size => 10, + labels => $sort_method eq "splitted" ? \%labels : \%u, + }, + } + ); +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Plugin/IsPauseClosed.pm b/lib/pause_2025/PAUSE/Web/Plugin/IsPauseClosed.pm new file mode 100644 index 000000000..b2ad6bd2d --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Plugin/IsPauseClosed.pm @@ -0,0 +1,41 @@ +package PAUSE::Web::Plugin::IsPauseClosed; + +use Mojo::Base "Mojolicious::Plugin"; +use HTTP::Date (); +use Time::Duration (); + +sub register { + my ($self, $app, $conf) = @_; + + $app->helper(pause_is_closed => \&_check); +} + +sub _check { + my $c = shift; + my $dti = PAUSE::downtimeinfo(); + my $downtime = $dti->{downtime}; + my $willlast = $dti->{willlast}; + my $pause = $c->stash(".pause"); + + if (time < $downtime) { + my $httptime = HTTP::Date::time2str($downtime); + my $delta = $downtime - time; + my $expr = Time::Duration::duration($delta); + my $willlast_dur = Time::Duration::duration($willlast); + $pause->{scheduled_downtime} = { + httptime => $httptime, + delta => $expr, + will_last => $willlast_dur, + }; + } elsif (time >= $downtime && time < $downtime + $willlast) { + my $delta = $downtime + $willlast - time; + my $expr = Time::Duration::duration($delta); + my $willlast_dur = Time::Duration::duration($willlast); + $pause->{closed} = { + delta => $expr, + will_last => $willlast_dur, + }; + } +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Plugin/MyURL.pm b/lib/pause_2025/PAUSE/Web/Plugin/MyURL.pm new file mode 100644 index 000000000..ab0908850 --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Plugin/MyURL.pm @@ -0,0 +1,29 @@ +package PAUSE::Web::Plugin::MyURL; + +use Mojo::Base "Mojolicious::Plugin"; +use Mojo::URL; + +sub register { + my ($self, $app, $conf) = @_; + + # Because we tweak url to pass ACTION param to path, + # we can't use default "url_for" that uses the tweaked path + # to generate a url + $app->helper(my_url => sub { + my $c = shift; + my $url = Mojo::URL->new($c->req->env->{REQUEST_URI}); + my $action = $c->stash('.pause')->{Action}; + my $requested_action = $url->query->param('ACTION') // ''; + $url->query->param(ACTION => $action) if $action && $action ne $requested_action; + $url->query->remove('ABRA'); + $url; + }); + $app->helper(my_full_url => sub { + my $c = shift; + my $url = Mojo::URL->new($c->req->env->{REQUEST_URI})->base($c->req->url->to_abs->base)->to_abs; + $url->query->remove('ABRA'); + $url; + }); +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Plugin/RenderYAML.pm b/lib/pause_2025/PAUSE/Web/Plugin/RenderYAML.pm new file mode 100644 index 000000000..3d3ad3078 --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Plugin/RenderYAML.pm @@ -0,0 +1,21 @@ +package PAUSE::Web::Plugin::RenderYAML; + +use Mojo::Base "Mojolicious::Plugin"; +use YAML::Syck; +use Encode; + +sub register { + my ($self, $app, $conf) = @_; + + $app->helper(render_yaml => sub { + my ($c, $data) = @_; + local $YAML::Syck::ImplicitUnicode = 1; + my $dump = YAML::Syck::Dump($data); + my $edump = Encode::encode_utf8($dump); + $c->stash(format => "text"); + $c->render(text => $edump); + return; + }); +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Plugin/ServePauseDoc.pm b/lib/pause_2025/PAUSE/Web/Plugin/ServePauseDoc.pm new file mode 100644 index 000000000..f3294c4be --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Plugin/ServePauseDoc.pm @@ -0,0 +1,53 @@ +package PAUSE::Web::Plugin::ServePauseDoc; + +use Mojo::Base "Mojolicious::Plugin"; +use PAUSE::Web::Util::RewriteXHTML; +use Encode; + +sub register { + my ($self, $app, $conf) = @_; + $app->helper(serve_pause_doc => \&_serve_pause_doc); +} + + +sub _serve_pause_doc { + my ($c, $name, $rewrite) = @_; + + my $home = $c->app->home; + + my $html; + for my $subdir ("htdocs", "pause", "pause/../htdocs", "pause/..", ".") { + my $file = $home->rel_file("$subdir/$name"); + next unless -f $file; + $html = decode_utf8($file->slurp); + if ($name =~ /\.md$/) { + require Text::Markdown::Hoedown; + $html = Text::Markdown::Hoedown::markdown($html); + $html =~ s!(.*?)!qq{$3}!ge; + } + last; + } + + if ($rewrite and !ref $rewrite) { + $html = PAUSE::Web::Util::RewriteXHTML->rewrite($html); + } else { + $html =~ s/^.*?]*>//si; + $html =~ s|.*$||si; + $html = $rewrite->($html) if $rewrite; + } + + $html ||= "document '$name' not found on the server"; + + $c->stash(".pause")->{doc} = $html; + $c->render("pause_doc"); +} + +sub _toc { + my ($num, $text) = @_; + $text = lc $text; + $text =~ s/[^a-z0-9_]+/_/g; + $text =~ s/(^_+|_+$)//g; + $text; +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Plugin/SessionCounted.pm b/lib/pause_2025/PAUSE/Web/Plugin/SessionCounted.pm new file mode 100644 index 000000000..1da5f3f8b --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Plugin/SessionCounted.pm @@ -0,0 +1,92 @@ +package PAUSE::Web::Plugin::SessionCounted; + +use Mojo::Base "Mojolicious::Plugin"; +use Mojo::File; +use Apache::Session::Counted; +use PAUSE (); + +our $SessionDataDir = "$PAUSE::Config->{RUNDATA}/session/sdata"; +our $SessionCounterDir = "$PAUSE::Config->{RUNDATA}/session/cnt"; + +sub register { + my ($self, $app, $conf) = @_; + + Mojo::File->new($SessionDataDir)->make_path; + Mojo::File->new($SessionCounterDir)->make_path; + + Apache::Session::CountedStore->tree_init($SessionDataDir, 1); + + $app->helper(session_data_dir => sub { $SessionDataDir }); + $app->helper(session_counted => \&_session); + $app->helper(new_session_counted => \&_new_session); + $app->helper(session_counted_userid => \&_userid); +} + +sub _session { + my $c = shift; + my $stash = $c->stash(".pause.session") or return; + $stash->{session}; +} + +sub _new_session { + my $c = shift; + my $stash = $c->stash(".pause.session"); + $c->stash(".pause.session" => $stash = {}) unless $stash; + + my $mgr = $c->app->pause; + my $sid = $c->req->param('USERID'); # may fail + my %session; + # XXX date string into CounterFile! + tie %session, 'Apache::Session::Counted', + $sid, { + Directory => $SessionDataDir, + DirLevels => 1, + CounterFile => _session_counter_file(), + }; + $stash->{session} = \%session; +} + +sub _session_counter_file { + my(@time) = gmtime; # sec,min,hour,day,month,year + my $quartal = int($time[4]/3) + 1; # 1..4 + "$SessionCounterDir/Q$quartal"; +} + +sub _userid { + my $c = shift; + my $stash = $c->stash(".pause.session"); + + # I'm working for the first time with Apache::Session::Counted + # Things have changed a bit. Until today we had no userid until we + # had dumped the current request. With Apache::Session we have a + # userid from the moment we open a session. Under many circumstances + # we do not need a session, so we do not need a userid. We typically + # need a userid either to retrieve an old value or to store a new + # value. We know that we have to retrieve an old value if there is a + # USERID=xxx parameter on the request. We know that we want to store + # something if we call ->userid. + + # Apache::Session will dump the current request even if we do not + # need it. That's stupid. Cookie based session concepts are + # careless. But let's delay this discussion and see if our code + # works first. + + return $stash->{userid} if defined $stash->{userid}; + # we must find out if there is an old request that needs to be + # restored because if there is, we must not create a new one. + # Because if we create a new one, the restorer cannot restore it + # without clobbering _session_id + + # Talking about session: lets delegate the problem to the session + + my $session = $c->session_counted; + $stash->{userid} = $session->{_session_id}; + $session->{_session_id} = $stash->{userid};# funny, isn't it? We + # trigger a STORE here + # which triggers a + # MODIFIED so that the + # DESTROY will actually + # save the hash +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Plugin/TextFormat.pm b/lib/pause_2025/PAUSE/Web/Plugin/TextFormat.pm new file mode 100644 index 000000000..5f8fd2159 --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Plugin/TextFormat.pm @@ -0,0 +1,18 @@ +package PAUSE::Web::Plugin::TextFormat; + +use Mojo::Base "Mojolicious::Plugin"; +use Mojo::ByteStream; +use Text::Format; + +sub register { + my ($self, $app, $conf) = @_; + $app->helper(text_format => \&_text_format); +} + +sub _text_format { + my ($c, $block) = @_; + my $result = $block->(); + Mojo::ByteStream->new(Text::Format->new(firstIndent => 0)->format($result)); +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Plugin/UserRegistration.pm b/lib/pause_2025/PAUSE/Web/Plugin/UserRegistration.pm new file mode 100644 index 000000000..d592228c4 --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Plugin/UserRegistration.pm @@ -0,0 +1,136 @@ +package PAUSE::Web::Plugin::UserRegistration; + +use Mojo::Base "Mojolicious::Plugin"; +use PAUSE::Crypt; +use HTTP::Tiny 0.059; +use IO::Socket::SSL 1.56; +use Net::SSLeay 1.49; +use JSON::XS; + +sub register { + my ($self, $app, $conf) = @_; + $app->helper(verify_recaptcha => \&_verify_recaptcha); + $app->helper(set_onetime_password => \&_set_onetime_password); + $app->helper(send_otp_email => \&_send_otp_email); + $app->helper(send_welcome_email => \&_send_welcome_email); + $app->helper(auto_registration_rate_limit_ok => \&_auto_registration_rate_limit_ok); +} + +# return values are $ok, $err; $ok undef means unknown validation; +# $ok defined true/false indicates whether verification succeeded. If +# completed but failed, $err will have error message(s). +sub _verify_recaptcha { + my ($c, $token) = @_; + if ( ! $PAUSE::Config->{RECAPTCHA_SECRET_KEY} ) { + warn "_verify_recaptcha: RECAPTCHA_SECRET_KEY not available\n"; + return; + } + + my $ht = HTTP::Tiny->new; + my $ok = undef; + my $err = ""; + eval { + my $res = $ht->post_form( + "https://www.google.com/recaptcha/api/siteverify", + { secret => $PAUSE::Config->{RECAPTCHA_SECRET_KEY}, response => $token } + ); + if ( $res->{success} ) { + my $data = decode_json( $res->{content} ); + $ok = $data->{success}; + if ( ref $err eq 'ARRAY' ) { + $err = join(", ", @$err) + } + } + }; + + return $ok, $err; +} + +sub _set_onetime_password { + my ($c, $userid, $email) = @_; + my $pause = $c->stash('.pause'); + my $mgr = $c->app->pause; + + my $onetime = sprintf "%08x", rand(0xffffffff); + + my $sql = qq{INSERT INTO $PAUSE::Config->{AUTHEN_USER_TABLE} ( + $PAUSE::Config->{AUTHEN_USER_FLD}, + $PAUSE::Config->{AUTHEN_PASSWORD_FLD}, + secretemail, + forcechange, + changed, + changedby + ) VALUES ( + ?,?,?,?,?,? + )}; + my $pwenc = PAUSE::Crypt::hash_password($onetime); + my $dbh = $mgr->authen_connect; + local($dbh->{RaiseError}) = 0; + my $rc = $dbh->do($sql,undef,$userid,$pwenc,$email,1,time,$pause->{User}{userid}); + die PAUSE::Web::Exception + ->new(ERROR => + [qq{Query [$sql] failed. Reason:}, + $DBI::errstr, + qq{This is very unfortunate as we have no option to rollback. The user is now registered in mod.users and could not be +registered in authen_pause.$PAUSE::Config->{AUTHEN_USER_TABLE}}] + ) unless $rc; + $dbh->disconnect; + + return $onetime; +} + +sub _send_otp_email { + my ($c, $userid, $email, $onetime) = @_; + my $pause = $c->stash('.pause'); + my $mgr = $c->app->pause; + + local $pause->{email} = $email; + local $pause->{onetime} = $onetime; + my $otpwblurb = $c->render_to_string("email/admin/user/onetime_password", format => "email"); + my $header = { + Subject => qq{Temporary PAUSE password for $userid}, + }; + my $header_str = join "\n", map {"$_: $header->{$_}"} keys %$header; + warn "header[$header_str]otpwblurb[$otpwblurb]"; + $mgr->send_mail_multi( [ $email, $PAUSE::Config->{ADMIN} ], $header, $otpwblurb); +} + +sub _send_welcome_email { + my ($c, $to, $userid, $email, $fullname, $homepage, $entered_by) = @_; + my $pause = $c->stash('.pause'); + my $mgr = $c->app->pause; + + local $pause->{userid} = $userid; + local $pause->{email} = $email; + local $pause->{fullname} = $fullname; + local $pause->{homepage} = $homepage; + local $pause->{entered_by} = $entered_by; + my $blurb = $c->render_to_string("email/admin/user/welcome_user", format => "email"); + + my $header = { Subject => "Welcome new user $userid" }; + $mgr->send_mail_multi($to,$header,$blurb); + + return ($header->{Subject}, $blurb); +} + +sub _auto_registration_rate_limit_ok { + my $c = shift; + my $pause = $c->stash('.pause'); + my $mgr = $c->app->pause; + + my $limit = $PAUSE::Config->{RECAPTCHA_DAILY_LIMIT}; + + # $limit 0 or undef means "no limit" + return 1 if !$limit; + + my $dbh = $mgr->connect; + my ($new_users) = $dbh->selectrow_array( + qq{ SELECT COUNT(*) FROM users where introduced > ? }, + undef, time - 24 * 3600, + ); + warn "new_user $new_users <= limit $limit?"; + + return $new_users <= $limit; +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Plugin/WrapAction.pm b/lib/pause_2025/PAUSE/Web/Plugin/WrapAction.pm new file mode 100644 index 000000000..c7ced54fd --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Plugin/WrapAction.pm @@ -0,0 +1,54 @@ +package PAUSE::Web::Plugin::WrapAction; + +use Mojo::Base "Mojolicious::Plugin"; +use HTTP::Status qw/:constants status_message/; + +sub register { + my ($self, $app, $conf) = @_; + + $app->hook(around_dispatch => \&_wrap); +} + +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}}, @{$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}) if $e->{HTTP_STATUS}; + $c->render('layouts/layout') unless $c->stash('Action'); + } elsif ($e->{HTTP_STATUS}) { + $c->res->headers->content_type('text/plain'); + $c->res->body(status_message($e->{HTTP_STATUS})); + $c->rendered($e->{HTTP_STATUS}); + return; + } + } else { + # this is NOT a known error type, we need to handle it anon + my $error = "$e"; + if ($pause->{ERRORS_TO_BROWSER}) { + push @{$pause->{ERROR}}, " ", $error; + } else { + $c->app->pause->log({level => 'error', message => $error }); + $c->res->code(HTTP_INTERNAL_SERVER_ERROR); + $c->reply->exception($error); + return; + } + } + } + return $res; +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Util/Encode.pm b/lib/pause_2025/PAUSE/Web/Util/Encode.pm new file mode 100644 index 000000000..bf66e51c3 --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Util/Encode.pm @@ -0,0 +1,69 @@ +package PAUSE::Web::Util::Encode; + +# XXX: Should be replaced with plain Encode eventually + +use Mojo::Base; +use Encode; +use HTML::Entities; +use Unicode::String; + +{ + our %entity2char = %HTML::Entities::entity2char; + while (my($k,$v) = each %entity2char) { + if ($v =~ /[^\000-\177]/) { + $entity2char{$k} = Unicode::String::latin1($v)->utf8; + # warn "CONV k[$k] v[$v]"; + } else { + delete $entity2char{$k}; + # warn "DEL v[$v]"; + } + } +} + +sub any2utf8 { + my $s = shift; + return $s unless defined $s; + + if ($s =~ /[\200-\377]/) { + # warn "s[$s]"; + my $warn; + local $^W=1; + local($SIG{__WARN__}) = sub { $warn = $_[0]; warn "warn[$warn]" }; + my($us) = Unicode::String::utf8($s); + if ($warn and $warn =~ /utf8|can't/i) { + warn "DEBUG: was not UTF8, we suppose latin1 (apologies to shift-jis et al): s[$s]"; + $s = Unicode::String::latin1($s)->utf8; + warn "DEBUG: Now converted to: s[$s]"; + } else { + warn "seemed to be utf-8"; + } + } + $s = _decode_highbit_entities($s); # modifies in-place + Encode::_utf8_on($s); + $s; +} + +sub _decode_highbit_entities { + my $s = shift; + # warn "s[$s]"; + my $c; + use utf8; + for ($s) { + s{ ( & \# (\d+) ;? ) + }{ ($2 > 127) ? chr($2) : $1 + }xeg; + + s{ ( & \# [xX] ([0-9a-fA-F]+) ;? ) + }{$c = hex($2); $c > 127 ? chr($c) : $1 + }xeg; + + s{ ( & (\w+) ;? ) + }{my $r = $entity2char{$2} || $1; warn "r[$r]2[$2]"; $r; + }xeg; + + } + # warn "s[$s]"; + $s; +} + +1; diff --git a/lib/pause_2025/PAUSE/Web/Util/RewriteXHTML.pm b/lib/pause_2025/PAUSE/Web/Util/RewriteXHTML.pm new file mode 100644 index 000000000..a12fef82c --- /dev/null +++ b/lib/pause_2025/PAUSE/Web/Util/RewriteXHTML.pm @@ -0,0 +1,82 @@ +package PAUSE::Web::Util::RewriteXHTML; + +# XXX: Should be rewritten to use HTML5 eventually + +use Mojo::Base; +use XML::SAX::ParserFactory; +use XML::SAX::Writer; +use XML::LibXML::SAX; +$XML::SAX::ParserPackage = "XML::LibXML::SAX"; + +sub rewrite { + my ($self, $html) = @_; + + my $w = XML::SAX::Writer->new(Output => \@out); + my $f = PAUSE::Web::Util::RewriteXHTML::Filter->new(Handler => $w); + my $p = XML::SAX::ParserFactory->parser(Handler => $f); + $p->parse_string($html); + while ($out[0] =~ /^<[\?\!]/){ # remove XML Declaration, DOCTYPE + shift @out; + } + join "", @out; +} + + + +package PAUSE::Web::Util::RewriteXHTML::Filter; + +use Mojo::Base "XML::SAX::Base"; + +sub start_element { + my ($self, $prop) = @_; + if ($prop->{Name} eq "body") { + $self->{InBody}++; + return; + } + return unless $self->{InBody}; + if ($prop->{Name} eq "a") { + my $href; + + $href = $prop->{Attributes}{"{}href"}{Value} if + $prop->{Attributes} && + $prop->{Attributes}{"{}href"} && + $prop->{Attributes}{"{}href"}{Value}; + + if (0) { + } elsif (!$href) { + # anchor + } elsif ($href =~ m{ ^ (?:ftp|http|https) : // }x ) { + # absolute + } elsif ($href =~ m{ ^ (?:mailto) : }x ) { + # absolute + } elsif ($href =~ m{^\#}) { + # anchor + } else { + $prop->{Attributes}{"{}href"}{Value} =~ s{^}{http://www.cpan.org/modules/}; + } + } + + $self->SUPER::start_element($prop); +} + +sub end_element { + my ($self, $prop) = @_; + if ($prop->{Name} eq "body") { + $self->{InBody}--; + return; + } + return unless $self->{InBody}; + $self->SUPER::end_element($prop); +} + +sub characters { + my ($self, $prop) = @_; + return unless $self->{InBody}; + $self->SUPER::characters($prop); +} + +sub doctype_decl { return; } + +sub processing_instruction { return; } + +1; diff --git a/lib/pause_2025/TODO b/lib/pause_2025/TODO new file mode 100644 index 000000000..6f15579c2 --- /dev/null +++ b/lib/pause_2025/TODO @@ -0,0 +1,27 @@ +Things I hope to have done at PTS and afterwards: + +- Write more tests, especially using latin-1 (and Asian/Emoji) characters +- Replace "require ..." with "use ..." to preload +- Move lib/pause_2017/t/ directory into t/ when tests are ready for travis.ci +- Wrap <%= %> stuff with to make them easier to find/test (by Mech/Web::Scraper etc) +- Port spurious warn and print STDERR to ->log(level => "debug", ...) +- Replace YAML::Syck with something else +- Kill PAUSE::Web::Exception where appropriate, most of which can be replaced with return + $pause->{some_flags} + template blocks +- Add csrf_token where necessary (add_uri shouldn't have it yet, and some other pages too, or at least without prior discussion because some people use scripts to modify their PAUSE data) +- Consider removing/replacing some plugins +- Replace XHTML with HTML5 if time permits, to remove a dirty hack on TagHelpers +- Incorporate fixes that have been merged to Andreas' master + +- Drop HTTP support +- Remove modulelist related stuff + +Things that'll take more time to address (to avoid double encoding etc): + +- Replace PAUSE::Web::Util::Encode with plain Encode +- Replace $mgr->fetchrow with $sth->fetchrow_* +- PAUSE seems to have data that don't work with newer MySQL (because of stricter datetime format etc) + +Things that need discussion + +- It would be nice if we can directly use some of the paused/mldistwatch features in the web UI tests +- Pagers and table sorters, to make frequent uploaders (probably) happy => as long as javascript is not used (Andreas' strong preference) diff --git a/lib/pause_2025/templates/_closed.html.ep b/lib/pause_2025/templates/_closed.html.ep new file mode 100644 index 000000000..c292fb145 --- /dev/null +++ b/lib/pause_2025/templates/_closed.html.ep @@ -0,0 +1,3 @@ +% my $pause = stash(".pause") || {}; +% my $closed = $pause->{closed}; +

PAUSE is closed for maintainance for about <%= $closed->{will_last} %>. Estimated time of opening is in <%= $closed->{delta} %>.

Sorry for the inconvenience and Thanks for your patience.

diff --git a/lib/pause_2025/templates/_debug.html.ep b/lib/pause_2025/templates/_debug.html.ep new file mode 100644 index 000000000..6d665966c --- /dev/null +++ b/lib/pause_2025/templates/_debug.html.ep @@ -0,0 +1,285 @@ +%# stolen from Mojolicious' default debug template +% unless ($ENV{TEST_PAUSE_WEB}) { + + +
+ % my $kv = begin + % my ($key, $value) = @_; + + <%= $key %>: + 
<%= $value %>
+ + % end + % if (my $exception = stash 'exception') { +
+ % my $cv = begin + % my ($key, $value, $i) = @_; + %= tag 'tr', $i ? (class => 'important') : (), begin + <%= $key %> + + 
<%= $value %>
+ + % end + % end +
+ 
<%= $exception->message %>
+
+ + % for my $line (@{$exception->lines_before}) { + %= $cv->($line->[0], $line->[1]) + % } + % if (defined $exception->line->[1]) { + %= $cv->($exception->line->[0], $exception->line->[1], 1) + % } + % for my $line (@{$exception->lines_after}) { + %= $cv->($line->[0], $line->[1]) + % } +
+
+ % if (defined $exception->line->[2]) { +
+ + % for my $line (@{$exception->lines_before}) { + %= $cv->($line->[0], $line->[2]) + % } + %= $cv->($exception->line->[0], $exception->line->[2], 1) + % for my $line (@{$exception->lines_after}) { + %= $cv->($line->[0], $line->[2]) + % } +
+
+
tap for more
+ + % } +
+
+ % if (@{$exception->frames}) { +
+ + % for my $frame (@{$exception->frames}) { + + + + % } +
+ 
<%= $frame->[1] . ':' . $frame->[2] %>
+
+
+ % } +
+ % } + % else { +%if (0) { +
+ % my $walk = begin + % my ($walk, $route, $depth) = @_; + + + % my $pattern = $route->pattern->unparsed || '/'; + % $pattern = "+$pattern" if $depth; + 
<%= '  ' x $depth %><%= $pattern %>
+ + + 
<%= uc(join ',', @{$route->via || []}) || '*' %>
+ + + % my $name = $route->name; + 
<%= $route->has_custom_name ? qq{"$name"} : $name %>
+ + + % $depth++; + %= $walk->($walk, $_, $depth) for @{$route->children}; + % $depth--; + % end + + + + + + + + + %= $walk->($walk, $_, 0) for @{app->routes->children}; +
PatternMethodsName
+
+%} + % } +
+ + % my $req = $c->req; + %= $kv->(Method => $req->method) + % my $url = $req->url; + %= $kv->(URL => $url->to_string) + %= $kv->('Base URL' => $url->base->to_string) + %= $kv->(Parameters => dumper $req->params->to_hash) + %= $kv->(Stash => dumper $c->stash) + %= $kv->(Session => dumper session) + %= $kv->(Version => $req->version) + % for my $name (sort @{$c->req->headers->names}) { + % my $value = $c->req->headers->header($name); + %= $kv->($name, $value) + % } + %= $kv->(Env => dumper $req->env) + %= $kv->(UserInfo => dumper $req->url->userinfo) +
+
+% if (0) { +
+
+ + %= $kv->(Perl => "$^V ($^O)") + % my $version = $Mojolicious::VERSION; + % my $codename = $Mojolicious::CODENAME; + %= $kv->(Mojolicious => "$version ($codename)") + %= $kv->(Home => app->home) + %= $kv->('Template paths' => dumper app->renderer->paths) + %= $kv->('Template classes' => dumper app->renderer->classes) + %= $kv->('Static paths' => dumper app->static->paths) + %= $kv->('Static classes' => dumper app->static->classes) + %= $kv->(Include => dumper \@INC) + %= $kv->(Config => dumper app->config) + %= $kv->(Moniker => app->moniker) + %= $kv->(Name => $0) + %= $kv->(Executable => $^X) + %= $kv->(PID => $$) + %= $kv->(Time => scalar localtime(time)) +
+
+
+% } +% if (0) { + % if (@{app->log->history}) { +
+ + % for my $msg (@{app->log->history}) { + + + + % } +
+ 
<%= app->log->format->(@$msg) %>
+
+
+ % } +% } +
+% } \ No newline at end of file diff --git a/lib/pause_2025/templates/_user_menu.html.ep b/lib/pause_2025/templates/_user_menu.html.ep new file mode 100644 index 000000000..279e193af --- /dev/null +++ b/lib/pause_2025/templates/_user_menu.html.ep @@ -0,0 +1,46 @@ +% my $pause = stash(".pause") || {}; +% my $user = $pause->{User} || {}; +% my $user_groups = $pause->{UserGroups} || {}; +% my $is_public = $c->req->url->path =~ /^query/ ? 1 : 0; +% my @offer_groups = app->pause->config->public_groups; +% $pause->{Action} ||= "menu"; +% if (%$user) { +% unshift @offer_groups, "user"; +% for my $group (app->pause->config->extra_groups) { +% push @offer_groups, $group if exists $user_groups->{$group} || exists $user_groups->{admin}; +% } +% } + diff --git a/lib/pause_2025/templates/_user_status.html.ep b/lib/pause_2025/templates/_user_status.html.ep new file mode 100644 index 000000000..e0cf3eb04 --- /dev/null +++ b/lib/pause_2025/templates/_user_status.html.ep @@ -0,0 +1,22 @@ +% my $pause = stash(".pause") || {}; +% my $remote_user = $c->req->env->{REMOTE_USER}; +% if ($remote_user and $remote_user ne "-") { + % my $user = $pause->{User}; + % my $status_class = $pause->{is_ssl} ? "statusencr" : "statusunencr"; + % my $email = $user->{secretemail} || $user->{email} || "No email???"; + % my $hidden_user = $pause->{HiddenUser}; + % my $hidden_user_email = $hidden_user->{secretemail} || $hidden_user->{email} || "No email???"; +
+ <%= $remote_user %> <>
+ % if ($hidden_user and $user and $hidden_user->{userid} and $user->{userid} and $hidden_user->{userid} ne $user->{userid}) { + acting as <%= $hidden_user->{userid} %> <<%= $hidden_user_email %>>
+ % } + + % if ($pause->{is_ssl}) { + encrypted session + % } else { + unencrypted session + % } + +
+% } diff --git a/lib/pause_2025/templates/admin/edit_ml.html.ep b/lib/pause_2025/templates/admin/edit_ml.html.ep new file mode 100644 index 000000000..c445e33aa --- /dev/null +++ b/lib/pause_2025/templates/admin/edit_ml.html.ep @@ -0,0 +1,74 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + +Excerpt from a mail:
+
+   From: andreas.koenig@anima.de (Andreas J. Koenig)
+   To: kstar@chapin.edu
+   Subject: Re: [elagache@ipn.caida.org: No email found for CAIDA? (Re: Missing CAIDA password?)]
+   Date: 02 Nov 2000 17:59:28 +0100
+
+   A mailing list occupies the same namespace as users because we do
+   not want that users and mailing lists get confused. But a mailing
+   list does not have a password and does not have a directory of its
+   own. Only people can upload and occupy a directory and have a
+   password. (It's clear that the user namespace is not related to the
+   modules namespace, right?)
+
+   The Module List may list a mailinglist as "the contact", so the
+   field userid in the table mods identifies either a mailing list or
+   a user. This has been useful in the past when several clueful
+   people represent several related modules and use a common mailing
+   list as the contact.
+
+   The table list2user maps mailing lists to their owners so that the
+   owners can edit the data associated with the mailing list like
+   address and comment. The table list2user does not have a web
+   interface because we are not really established as the primary
+   source for mailing list information and so it has not been used
+   much. But I'm open to offer one if you believe it's useful.
+   [...]
+
+ + + +<%= select_field "pause99_edit_ml_3" => $pause->{mls}, + size => (@{$pause->{mls}} > 18 ? 15 : scalar @{$pause->{mls}}), +=%> +
+
+% if (%{$pause->{selected} || {}}) { +

Record for <%= $pause->{selected}{maillistid} %>

+ +

The name of the mailing list

+

The name appears in the CPAN authors list, so it is good if the name contains the term mailing list or something equivalent

+<%= text_field pause99_edit_ml_maillistname => $pause->{selected}{maillistname}, + size => 50, + maxsize => 64, +=%> +
+ +

The address of the mailing list

+

This is the address where people post to (where all members of the group can be contacted)

+<%= text_field pause99_edit_ml_address => $pause->{selected}{address}, + size => 50, +=%> +
+ +

How to subscribe

+

This is a text that describes how to join the mailing list. E.g. the mailing list subscribe address or a URL with more details.

+<%= text_area pause99_edit_ml_subscribe => $pause->{selected}{subscribe}, + rows => 5, + cols => 60, +=%> +
+ +
+% if ($pause->{changed}) { +

The record has been updated in the database

+% } elsif ($pause->{updated_sel}) { +

It seems to me the record was NOT updated. Maybe +nothing changed? Please take a closer look and inform an admin if +things didn't proceed as expected.

+% } +% } diff --git a/lib/pause_2025/templates/admin/email_for_admin.html.ep b/lib/pause_2025/templates/admin/email_for_admin.html.ep new file mode 100644 index 000000000..d1dad4034 --- /dev/null +++ b/lib/pause_2025/templates/admin/email_for_admin.html.ep @@ -0,0 +1,35 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + +

Query a combination of usertable table and user for public or private emails according to the preferences

+ +
+ + + + + + + + + +% for (@{$pause->{list} || []}) { + + + + +% } + +
idid@cpan.org gets forwarded to
<%= $_->{id} %>
+ +

"YAML") %>" style="text-decoration: none;">YAML +

+
+% content_for javascript => begin +%= javascript "/list.min.js" +%= javascript begin +var List = new List('emails', { + valueNames: ['userid', 'email'] +}); +% end +% end diff --git a/lib/pause_2025/templates/admin/manage_id/manage.html.ep b/lib/pause_2025/templates/admin/manage_id/manage.html.ep new file mode 100644 index 000000000..7636c12da --- /dev/null +++ b/lib/pause_2025/templates/admin/manage_id/manage.html.ep @@ -0,0 +1,54 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; +% my %ALL = %{$pause->{all} || {}}; +% my $json_encoder = JSON::XS->new->indent->canonical; + +

View all pending applications for new user IDs and for modules registrations

+ +
+ + + + + + + + + + + + +% for my $k (sort { $ALL{$b}{type} cmp $ALL{$a}{type} || $ALL{$b}{mtime} <=> $ALL{$a}{mtime} } keys %ALL) { + + + + + + + +% } + +
TypeUseridTimeRaw SessionActions
<%= $ALL{$k}{type} %><%= $ALL{$k}{session}{APPLY}{userid} %><%= POSIX::strftime("%FT%TZ", gmtime $ALL{$k}{mtime}) %>
<%= do {
+        my $json = $json_encoder->encode($ALL{$k}{session});
+        $json =~ s/\\n/\n/g;
+        $json;
+      } %>
 + $ALL{$k}{session}{_session_id}, + (exists $ALL{$k}{session}{APPLY}{fullname} ? "SUBMIT_pause99_add_user_sub" : "SUBMIT_pause99_add_mod_preview") => 1 + ) %>">Go To Registration +
+ "delete", + USERID => $ALL{$k}{session}{_session_id}, + ) %>">Delete Registration +
+
+% content_for javascript => begin +%= javascript "/list.min.js" +%= javascript begin +var requestList = new List('requests', {valueNames: ['type', 'userid', 'session']}); +% end +% end diff --git a/lib/pause_2025/templates/admin/select_user.html.ep b/lib/pause_2025/templates/admin/select_user.html.ep new file mode 100644 index 000000000..2fbe46f90 --- /dev/null +++ b/lib/pause_2025/templates/admin/select_user.html.ep @@ -0,0 +1,16 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + +<%= select_field "HIDDENNAME" => $pause->{hidden_name_list}, + size => 10, +=%> + +
+ +<%= select_field "ACTIONREQ" => $pause->{action_req_list}, + size => 13, +=%> + +
+ + diff --git a/lib/pause_2025/templates/admin/user/add.html.ep b/lib/pause_2025/templates/admin/user/add.html.ep new file mode 100644 index 000000000..33e1d3d9b --- /dev/null +++ b/lib/pause_2025/templates/admin/user/add.html.ep @@ -0,0 +1,202 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + +% if (param("pause99_add_user_userid")) { +% unless (@{$pause->{error} || []}) { +% if (my @urows = @{$pause->{urows} || []}) { # Soundex found something + +

Not submitting <%= $pause->{userid} %>, maybe we have a duplicate here

+

<%= $pause->{s_package} %> converted the fullname [<%= $pause->{fullname} %>] to [<%= $pause->{s_code} %>]

+ + + + + + +% for my $row (map { $_->{line} } sort { $b->{score} <=> $a->{score} } @urows) { + +% if ($row->{same_userid}) { + +% } elsif ($row->{userid}) { + +% } else { + +% } + +% if ($row->{same_fullname}) { + +% } elsif ($row->{surname}) { + +% } elsif ($row->{fullname}) { + +% } else { + +% } + +% if ($row->{same_email}) { + +% } else { + +% } + + + +% } +
useridfullname(public) emailother
<%= $row->{userid} %><%= $row->{userid} %> <%= $row->{fullname} %><%= $row->{before_surname} %><%= $row->{surname} %><%= $row->{after_surname} %><%= $row->{fullname} %> <%= $row->{email_parts}[0] %>
@<%= $row->{email_parts}[1] %>		<%= $row->{email_parts}[0] %>
@<%= $row->{email_parts}[1] %>		 +% if ($row->{same_secretemail}) { +secret email: <%= $row->{secretemail} %>
+% } elsif ($row->{secretemail}) { +secret email: <%= $row->{secret_email} %>
+% } + +% if ($row->{same_homepage}) { +homepage: <%= $row->{homepage} %>
+% } elsif ($row->{homepage}) { +homepage: <%= $row->{homepage} %>
+% } + +% if ($row->{introduced}) { +% my $time = $row->{introduced}; +% $time =~ s/\s/\ /g; +introduced on: <%== $time %>
+% } + +% if ($row->{changed}) { +% my $time = $row->{changed}; +% $time =~ s/\s/\ /g; +changed on: <%== $time %> by <%= $row->{changedby} %>
+% } else { +changed by <%= $row->{changedby} %>
+% } +
+% } +% } + +% if ($pause->{doit}) { +% if ($pause->{succeeded}) { + +

Submitting query

+

New user creation succeeded.

+ +% if ($pause->{subscribe}) { # mailing list +

Mailing list entered by <%= $pause->{User}{fullname} %>:

+

Userid: <%= $pause->{userid} %>

+

Name: <%= $pause->{maillistname} %>

+

Description: <%= $pause->{subscribe} %>

+% } else { # new user + +Sending separate mails to: <%= $pause->{send_to} %> +
+From: <%= $PAUSE::Config->{UPLOAD} %>
+Subject: <%= $pause->{subject} %>
+
+<%= $pause->{blurb} %>
+
+% } +% } else { +

Query [<%= $pause->{query} %>] failed. Reason:

<%= $pause->{query_error} %>

+ +% } + +Content of user record in table users:
+% if ($pause->{usertable}) { + +% for (sort keys %{$pause->{usertable}}) { + +% } +
<%= $_ %><%= $pause->{usertable}{$_} || b(" ") %>
+% } + +% } elsif (my @errors = @{$pause->{error} || []}) { +

Error processing form

+% for my $error (@errors) { +
  • +% if ($error->{invalid}) { +userid[<%= $pause->{userid} %>] does not match +<%= $c->app->pause->config->valid_userid %>. +% } elsif ($error->{no_fullname}) { +No fullname, nothing done. +% } +
+% } +

Please retry.

+% } +% } + +

Add a user or mailinglist

+ +<%= submit_button " Insert with soundex care ", + name => "SUBMIT_pause99_add_user_Soundex", +=%> +<%= submit_button " Insert with metaphone care ", + name => "SUBMIT_pause99_add_user_Metaphone", +=%> +<%= submit_button " Insert most definitely ", + name => "SUBMIT_pause99_add_user_Definitely", +=%> + +
+ +userid (entering lowercase is OK, but it will be uppercased by the server):
+ +<%= text_field "pause99_add_user_userid", + size => 12, + maxlength => 9, +=%> + +
+ +full name (mailinglist name):
+ +<%= text_field "pause99_add_user_fullname", + size => 50, + maxlength => 50 +=%> + +
+ +email address (for mailing lists this is the real address):
+ +<%= text_field "pause99_add_user_email", + size => 50, + maxlength => 50, +=%> + +
+ +homepage url (ignored for mailing lists):
+ +<%= text_field "pause99_add_user_homepage", + size => 50, + maxlength => 256 +=%> + +
+ +subscribe information if this user is a mailing list +(leave blank for ordinary users):
+ +<%= text_field "pause99_add_user_subscribe", + size => 50, + maxlength => 256, +=%> + +
+ +<%= submit_button " Insert with soundex care ", + name => "SUBMIT_pause99_add_user_Soundex", +=%> +<%= submit_button " Insert with metaphone care ", + name => "SUBMIT_pause99_add_user_Metaphone", +=%> +<%= submit_button " Insert most definitely ", + name => "SUBMIT_pause99_add_user_Definitely", +=%> + +
+ +

If this is a bad request: "delete", + USERID => $pause->{userid}, +) %>">Delete the ID request

diff --git a/lib/pause_2025/templates/closed.html.ep b/lib/pause_2025/templates/closed.html.ep new file mode 100644 index 000000000..599a23d80 --- /dev/null +++ b/lib/pause_2025/templates/closed.html.ep @@ -0,0 +1,7 @@ +PAUSE CLOSED + +

Closed for Maintainance

+%= include '_closed'; +

Andreas Koenig

+ + diff --git a/lib/pause_2025/templates/disabled.html.ep b/lib/pause_2025/templates/disabled.html.ep new file mode 100644 index 000000000..51465ae01 --- /dev/null +++ b/lib/pause_2025/templates/disabled.html.ep @@ -0,0 +1,5 @@ +% layouts 'layout', title => "Closed for Maintenance"; +% my $pause = stash(".pause") || {}; + +

Dear visitor,

+%== $pause->{message}; diff --git a/lib/pause_2025/templates/email/admin/edit_ml.email.ep b/lib/pause_2025/templates/email/admin/edit_ml.email.ep new file mode 100644 index 000000000..f6cb6e0c8 --- /dev/null +++ b/lib/pause_2025/templates/email/admin/edit_ml.email.ep @@ -0,0 +1,25 @@ +% my $pause = stash(".pause") || {}; +% +%#------------------------------------------------------------------ +% +Record update in the PAUSE mailinglists database: + +<%== sprintf "%12s: [%s]", "userid", $pause->{selected}{maillistid} %> +% for my $field (qw(maillistname address subscribe)) { +% my $fieldname = "pause99_edit_ml_$field"; +% my $param = param($fieldname); +% if ($param ne $pause->{selected}{$field}) { +<%== sprintf "%12s: [%s]", $field, $param %> was [<%== $pause->{selected}{$field} %>] +% } else { +<%== sprintf "%12s: [%s]", $field, $pause->{selected}{$field} %> +% } +% } +% if ($pause->{changed}) { + +Data entered by <%= $pause->{User}{fullname} %>. +Please check if they are correct. + +Thanks, +-- +The PAUSE Team +% } diff --git a/lib/pause_2025/templates/email/admin/user/onetime_password.email.ep b/lib/pause_2025/templates/email/admin/user/onetime_password.email.ep new file mode 100644 index 000000000..5b7aee6e6 --- /dev/null +++ b/lib/pause_2025/templates/email/admin/user/onetime_password.email.ep @@ -0,0 +1,26 @@ +% my $pause = stash(".pause") || {}; +% +%#------------------------------------------------------------------ +% + +(This mail has been generated automatically by the Perl Authors Upload +Server on behalf of the admin <%== $PAUSE::Config->{ADMIN} %>) + +As already described in a separate message, you're a registered Perl +Author with the userid <%== $pause->{userid} %>. For the sake of approval I have +assigned to you a change-password-only-password that enables +you to pick your own password. This password is "<%== $pause->{onetime} %>" +(without the enclosing quotes). Please visit + + <%== my_full_url->path("/pause/authenquery")->query(ACTION => "change_passwd")->scheme("https") %> + +and use this password to initialize your account in the authentication +database. Once you have entered your password there, your one-time +password is expired automatically. If you cannot connect to the above +URL, you can replace 'https' with 'http', but then you are not using +SSL encryption. Be careful to always use an SSL connection if +possible, otherwise your password can be intercepted by third parties. + +Thanks & Regards, +-- +<%== $PAUSE::Config->{ADMIN} %> diff --git a/lib/pause_2025/templates/email/admin/user/welcome_ml.email.ep b/lib/pause_2025/templates/email/admin/user/welcome_ml.email.ep new file mode 100644 index 000000000..3c9fef42e --- /dev/null +++ b/lib/pause_2025/templates/email/admin/user/welcome_ml.email.ep @@ -0,0 +1,13 @@ +% my $pause = stash(".pause") || {}; +% +%#------------------------------------------------------------------ +% +Mailing list entered by +<%== $pause->{User}{fullname} %>: + +Userid: <%== $pause->{userid} %> +Name: <%== $pause->{maillistname} %> +Description: +%= text_format begin +<%== $pause->{subscribe} %> +% end diff --git a/lib/pause_2025/templates/email/admin/user/welcome_user.email.ep b/lib/pause_2025/templates/email/admin/user/welcome_user.email.ep new file mode 100644 index 000000000..0640e15c2 --- /dev/null +++ b/lib/pause_2025/templates/email/admin/user/welcome_user.email.ep @@ -0,0 +1,35 @@ +% my $pause = stash(".pause") || {}; +% +%#------------------------------------------------------------------ +% +Welcome <%== $pause->{fullname} %>, + +PAUSE, the Perl Authors Upload Server, has a userid for you: + + <%== $pause->{userid} %> + +Once you've gone through the procedure of password approval (see the +separate mail you should receive about right now), this userid will be +the one that you can use to upload your work or edit your credentials +in the PAUSE database. + +This is what we have stored in the database now: + + Name: <%== $pause->{fullname} // '' %> + email: <%== $pause->{email} // '' %> + homepage: <%== $pause->{homepage} // '' %> + +Please note that your email address is exposed in various listings and +database dumps. You can register with both a public and a secret email +if you want to protect yourself from SPAM. If you want to do this, +please visit + <%== my_full_url->path("/pause/authenquery")->query(ACTION => "edit_cred" )->scheme("https") %> +or + <%== my_full_url->path("/pause/authenquery")->query(ACTION => "edit_cred" )->scheme("http") %> + +If you need any further information, please visit + $CPAN/modules/04pause.html. +If this doesn't answer your questions, contact modules@perl.org. + +Thank you for your prospective contributions, +The PAUSE Team diff --git a/lib/pause_2025/templates/email/public/mailpw.email.ep b/lib/pause_2025/templates/email/public/mailpw.email.ep new file mode 100644 index 000000000..761df49a8 --- /dev/null +++ b/lib/pause_2025/templates/email/public/mailpw.email.ep @@ -0,0 +1,28 @@ +% my $pause = stash(".pause") || {}; +% +%#------------------------------------------------------------------ +% + +(this an automatic mail sent by a program because somebody asked for +it. If you did not intend to get it, please let us know and we will +take more precautions to prevent abuse.) + +Somebody, probably you, has visited the URL + + <%== my_full_url->query(ACTION => "mailpw") %> + +and asked that you, "<%= $pause->{mailpw_userid} %>", should get a token that enables the +setting of a new password. Here it is (please watch out for line +wrapping errors of your mail reader and other cut and paste errors, +this URL must not contain any spaces): + + <%== my_full_url->path("/pause/query")->query(ACTION => "change_passwd", ABRA => "$pause->{mailpw_userid}.$pause->{passwd}")->scheme("https") %> + +Please visit this URL, it should open you the door to a password +changer that lets you set a new password for yourself. This token +will expire within a few hours. If you don't need it, do nothing. By +the way, your old password is still valid. + +Thanks, +-- +The PAUSE Team diff --git a/lib/pause_2025/templates/email/public/request_id.email.ep b/lib/pause_2025/templates/email/public/request_id.email.ep new file mode 100644 index 000000000..965f616e0 --- /dev/null +++ b/lib/pause_2025/templates/email/public/request_id.email.ep @@ -0,0 +1,25 @@ +% my $pause = stash(".pause") || {}; +% +%#------------------------------------------------------------------ +% +Request to register new user + +fullname: <%== $pause->{fullname} %> + userid: <%== $pause->{userid} %> + mail: CENSORED +homepage: <%== $pause->{homepage} %> + why: +<%== $pause->{rationale} %> + +The following links are only valid for PAUSE maintainers: + +Registration form with editing capabilities: + <%== my_full_url->path("/pause/authenquery")->scheme('https')->query( + ACTION => "add_user", + USERID => $pause->{session_id}, + SUBMIT_pause99_add_user_sub => 1) %> +Immediate (one click) registration: + <%== my_full_url->path("/pause/authenquery")->scheme('https')->query( + ACTION => "add_user", + USERID => $pause->{session_id}, + SUBMIT_pause99_add_user_Definitely => 1 ) %> diff --git a/lib/pause_2025/templates/email/user/change_passwd.email.ep b/lib/pause_2025/templates/email/user/change_passwd.email.ep new file mode 100644 index 000000000..cc37fe1b9 --- /dev/null +++ b/lib/pause_2025/templates/email/user/change_passwd.email.ep @@ -0,0 +1,15 @@ +% my $pause = stash(".pause") || {}; +% +%#------------------------------------------------------------------ +% +Password update on PAUSE: + +<%== $pause->{User}{userid} %> (<%== $pause->{User}{fullname} || "fullname N/A" %>) visited the +password changer on PAUSE at <%== scalar gmtime %> UTC +and changed the password for <%== $pause->{HiddenUser}{userid} %> (<%== $pause->{HiddenUser}{fullname} || "fullname N/A" %>). + +No action is required, but it would be a good idea if somebody +would check the correctness of the new password. + +Thanks, +The PAUSE Team diff --git a/lib/pause_2025/templates/email/user/cred/edit.email.ep b/lib/pause_2025/templates/email/user/cred/edit.email.ep new file mode 100644 index 000000000..62460d799 --- /dev/null +++ b/lib/pause_2025/templates/email/user/cred/edit.email.ep @@ -0,0 +1,18 @@ +% my $pause = stash(".pause") || {}; +% +%#------------------------------------------------------------------ +% +Record update in the PAUSE users database: + +<%== sprintf "%11s: [%s]", "userid", $pause->{HiddenUser}{userid} %> + +% for (@{$pause->{mailblurb}}) { +<%== sprintf "%11s: [%s]", $_->{field}, $_->{value} %><%== ($_->{was}) ? " was [$_->{was}]" : "" %> + +% } + +Data were entered by <%== $pause->{User}{userid} %> (<%== $pause->{User}{fullname} %>). +Please check if they are correct. + +Thanks, +The PAUSE Team diff --git a/lib/pause_2025/templates/email/user/delete_files.email.ep b/lib/pause_2025/templates/email/user/delete_files.email.ep new file mode 100644 index 000000000..ca74814e9 --- /dev/null +++ b/lib/pause_2025/templates/email/user/delete_files.email.ep @@ -0,0 +1,21 @@ +% my $pause = stash(".pause") || {}; +% +%#------------------------------------------------------------------ +% +%= text_format begin +According to a request entered by <%== $pause->{User}{fullname} %> the +following files and the symlinks pointing to them have been scheduled +for deletion. They will expire after 72 hours and then be deleted by a +cronjob. Until then you can undelete them via +<%== my_full_url->path("/pause/authenquery")->query(ACTION => "delete_files")->scheme("https") %> or +<%== my_full_url->path("/pause/authenquery")->query(ACTION => "delete_files")->scheme("http") %> +% end + +<%== $pause->{blurb} %> + +%= text_format begin +Note: to encourage deletions, all of past CPAN +glory is collected on http://history.perl.org/backpan/ +% end + +The PAUSE Team diff --git a/lib/pause_2025/templates/email/user/edit_uris.email.ep b/lib/pause_2025/templates/email/user/edit_uris.email.ep new file mode 100644 index 000000000..0ae3ba9f5 --- /dev/null +++ b/lib/pause_2025/templates/email/user/edit_uris.email.ep @@ -0,0 +1,34 @@ +% my $pause = stash(".pause") || {}; +% +% #----------------------------------------------------------------- +% +Record update in the PAUSE uploads database: + +% if ($pause->{selected}) { +<%== sprintf("%12s: [%s]", "uriid", $pause->{selected}{uriid} %> +% for my $field (qw( +% uri +% nosuccesstime +% nosuccesscount +% changed +% changedby +% )) { +% my $fieldname = "pause99_edit_uris_$field"; +% my $param = param($fieldname); +% if ($param ne $pause->{selected}{$field}) { +<%== sprintf("%12s: [%s]", $field, $param) %> was [<%= $pause->{selected}{$field} %>] +% } else { +<%== sprintf("%12s: [%s]", $field, $pause->{selected}{$field} %> +% } +% } +% if ($pause->{changed}) { + +Data entered by <%== $pause->{User}{fullname} %> (<%== $pause->{User}{userid} %>). +Please check if they are correct. + +Thanks, +-- +The PAUSE Team +% } +% } + diff --git a/lib/pause_2025/templates/email/user/reindex.email.ep b/lib/pause_2025/templates/email/user/reindex.email.ep new file mode 100644 index 000000000..01c1b0dc1 --- /dev/null +++ b/lib/pause_2025/templates/email/user/reindex.email.ep @@ -0,0 +1,15 @@ +% my $pause = stash(".pause") || {}; +% +%#------------------------------------------------------------------ +% +According to a request entered by <%== $pause->{User}{fullname} %> the +following files have been scheduled for reindexing. + +<%== $pause->{blurb} %> + +Estimated time of job completion: <%== $pause->{eta} %> + +Thanks, +-- +The PAUSE Team + diff --git a/lib/pause_2025/templates/email/user/reset_version.email.ep b/lib/pause_2025/templates/email/user/reset_version.email.ep new file mode 100644 index 000000000..64d19a014 --- /dev/null +++ b/lib/pause_2025/templates/email/user/reset_version.email.ep @@ -0,0 +1,12 @@ +% my $pause = stash(".pause") || {}; +% +%#------------------------------------------------------------------ +% +According to a request by <%== $pause->{User}{fullname} %> the following +packages have their recorded version set to 'undef'. + +<%== $pause->{blurb} %> + +Thanks, +-- +The PAUSE Team diff --git a/lib/pause_2025/templates/email/user/uri/submission.email.ep b/lib/pause_2025/templates/email/user/uri/submission.email.ep new file mode 100644 index 000000000..1ed7652d5 --- /dev/null +++ b/lib/pause_2025/templates/email/user/uri/submission.email.ep @@ -0,0 +1,30 @@ +% my $pause = stash(".pause") || {}; +% +%#------------------------------------------------------------------ +% +%= text_format begin +<%== $pause->{User}{userid} %> (<%== $pause->{User}{fullname} %>) visited the PAUSE and requested an upload +into <%== $pause->{whose} %> directory. The request used the following parameters:} + +% end +% for (@{$pause->{mb} || []}) { +<%== sprintf qq{ %-*s [%s]}, $pause->{longest}, $_->[0], $_->[1] %> +% } + +% if ($pause->{query_succeeded}) { +%= text_format begin +The request is now entered into the database where the PAUSE daemon +will pick it up as soon as possible (usually 1-2 minutes). + + +During upload you can watch the logfile in <%== $pause->{tailurl} %>. + +You'll be notified as soon as the upload has succeeded, and if the +uploaded package contains modules, you'll get another notification +from the indexer a little later (usually within 1 hour). +% end +% } + +Thanks for your contribution, +-- +The PAUSE Team diff --git a/lib/pause_2025/templates/layouts/layout.html.ep b/lib/pause_2025/templates/layouts/layout.html.ep new file mode 100644 index 000000000..99176952c --- /dev/null +++ b/lib/pause_2025/templates/layouts/layout.html.ep @@ -0,0 +1,100 @@ +% my $pause = stash(".pause") || {}; +% my $title = $PAUSE::Config->{TESTHOST} ? "pause\@home: " : "PAUSE: "; +% my $action = $pause->{action} || "The CPAN back stage entrance"; +% +% #----------------------------------------------------------------- +% + + + + + +<%= $title %><%= $action %> + + + + + + +
+
+
+

PAUSE Logo + The [Perl programming] Authors Upload Server

+
+
+ %= include "_user_status"; +
+
+
+ +% if (my $downtime = $pause->{scheduled_downtime}) { + +
+
+

+ Scheduled downtime
+ On <%= $downtime->{http_time} %> (that is in <%= $downtime->{delta} %>) PAUSE will be closed for maintainance work. The estimated downtime is <%= $downtime->{will_last} %>. +

+
+
+% } elsif ($pause->{closed}) { + % my $user = $c->req->env->{REMOTE_USER}; +
+
+

Hi <%= $user %>, you see the site now but it is closed for maintainance. +Please be careful not to disturb the database operation. Expect failures everywhere. Do not edit anything, it may get lost. Other users get the following text:

+%= include "_closed"; +
+
+% } + +% if ($pause->{ERROR}) { +
+
+

Error

+

+% for (@{$pause->{ERROR}}) { +<%= $_ %> +% } +

+

Please try again, probably by using the Back button of your browser and repeating the last action you took.

+
+
+% } else { +
+
+ %= include "_user_menu"; +
+
+ % my $action_conf = app->pause->config->action($pause->{Action}); + % my $me = my_url(); + % my $method = $action_conf->{method} // 'GET'; + % my $enctype; + % if ($pause->{need_form_data}) { + % $enctype = "multipart/form-data"; + % } + % if ($PAUSE::Config->{TESTHOST}) { + % warn "DEBUG: me[$me]enctype[$enctype]"; +

[ATTN: Form going to post to <%= $me %>]

+ % } +
enctype="<%= $enctype %>" <% } %>method="<%= $method %>"> + % if (!$action_conf->{method}) { + + % } +
+ % if (my $verb = $action_conf->{verb} and !$action_conf->{has_title}) { +

<%= $verb %>

+ % } + <%== content %> +
+
+
+
+% } +% if ($ENV{PAUSE_WEB_DEBUG} // $PAUSE::Config->{PAUSE_WEB_DEBUG}) { + %= include "_debug"; +% } +%== content 'javascript' + + diff --git a/lib/pause_2025/templates/mlrepr/select_ml_action.html.ep b/lib/pause_2025/templates/mlrepr/select_ml_action.html.ep new file mode 100644 index 000000000..ca3d936a9 --- /dev/null +++ b/lib/pause_2025/templates/mlrepr/select_ml_action.html.ep @@ -0,0 +1,44 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + +

+Mailinglist support is intended to be available on a +delegates/representatives basis, that means, one or more users +are "elected" (no formal election though) to be allowed to act +on behalf of a mailing list. There is no password for a mailing +list, there are no user credentials for a mailing list. There +are no uploads for mailing lists, thus no deletes or repairs of +uploads. +

+

+There are only the infos about the mailing list +editable via the method edit_ml and ther are a number of +modules associated with a mailing list and these are accessible +in the edit_mod method. +

+

+The menu item Select +Mailinglist/Action lets you access the available methods and +the mailing lists you are associated with. Only people elected +as a representative of a mailing list should be able to ever see +the menu entry.

This feature is available since Oct 25th, +1999 and hardly tested, so please take care and let us know how +it goes. +

+ +

Choose your mailing list and the action and click the submit +button.

+ +<%= select_field HIDDENNAME => [ + map { + $_ eq $pause->{User}{userid} + ? [$_ => $_, selected => "selected"] + : $_ + } @{$pause->{users}} +], size => (@{$pause->{users}} > 18 ? 15 : scalar @{$pause->{users}}), +%> +<%= select_field ACTIONREQ => $pause->{action_reqs}, + size => (@{$pause->{action_reqs}} > 18 ? 15 : scalar @{$pause->{action_reqs}}), +%> + + diff --git a/lib/pause_2025/templates/mlrepr/show_ml_repr.html.ep b/lib/pause_2025/templates/mlrepr/show_ml_repr.html.ep new file mode 100644 index 000000000..d0b7e14f9 --- /dev/null +++ b/lib/pause_2025/templates/mlrepr/show_ml_repr.html.ep @@ -0,0 +1,32 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + +

These are the contents of the table list2user. +There's currently no way to edit the table except +direct SQL. The table says who is representative of a +mailing list.

+ +
+ + + + + + + + + % for my $rec (@{$pause->{lists} || []}) { + + + + + % } + +
Mailing listUser-ID
<%= $rec->{maillistid} %><%= $rec->{userid} %>
+
+% content_for javascript => begin +%= javascript "/list.min.js" +%= javascript begin +var userList = new List('users', {valueNames: ['ml', 'userid']}); +% end +% end diff --git a/lib/pause_2025/templates/pause_doc.html.ep b/lib/pause_2025/templates/pause_doc.html.ep new file mode 100644 index 000000000..315ad5a81 --- /dev/null +++ b/lib/pause_2025/templates/pause_doc.html.ep @@ -0,0 +1,4 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + +%== $pause->{doc} diff --git a/lib/pause_2025/templates/public/admin.html.ep b/lib/pause_2025/templates/public/admin.html.ep new file mode 100644 index 000000000..4b2a11ad7 --- /dev/null +++ b/lib/pause_2025/templates/public/admin.html.ep @@ -0,0 +1,8 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + +

Query the grouptable table for who is an admin bit holder

+

Registered admins: <%= join ", ", @{$pause->{admins} || []} %>

+

"YAML") %>" style="text-decoration: none;"> +YAML +

diff --git a/lib/pause_2025/templates/public/mailpw.html.ep b/lib/pause_2025/templates/public/mailpw.html.ep new file mode 100644 index 000000000..89576372e --- /dev/null +++ b/lib/pause_2025/templates/public/mailpw.html.ep @@ -0,0 +1,21 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; +%= csrf_field + +"> + +% if ($pause->{mailpw_userid}) { +% if ($pause->{valid_email}) { +

A token to change the password for <%= $pause->{mailpw_userid} %> is on its way to its owner. Should the mail not arrive, please tell us.

+% } else { +

We have not found the email of <%= $pause->{mailpw_user_id} %>. Please try with a different name or mail to the administrator directly.

+% } +% } + +

This form lets you request a token that enables you to set a new +password. It only operates correctly if the database knows you and +your email adress. Please fill in your userid on the CPAN. The token +will be mailed to that userid.

+ +<%= text_field "pause99_mailpw_1", size => 32 %> + diff --git a/lib/pause_2025/templates/public/pumpkin.html.ep b/lib/pause_2025/templates/public/pumpkin.html.ep new file mode 100644 index 000000000..bdb2bb324 --- /dev/null +++ b/lib/pause_2025/templates/public/pumpkin.html.ep @@ -0,0 +1,8 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + +

Query the grouptable table for who is a pumpkin bit holder

+

Registered pumpkins: <%= join ", ", @{$pause->{pumpkins} || []} %>

+

"YAML") %>" style="text-decoration: none;"> +YAML +

diff --git a/lib/pause_2025/templates/public/request_id/_form.html.ep b/lib/pause_2025/templates/public/request_id/_form.html.ep new file mode 100644 index 000000000..b090853b1 --- /dev/null +++ b/lib/pause_2025/templates/public/request_id/_form.html.ep @@ -0,0 +1,63 @@ +% my $pause = stash(".pause") || {}; +% my $alt = 0; + +

A PAUSE account is only required to distribute and manage Perl module +distributions on CPAN. You do not need a PAUSE account to submit +bug reports to RT or participate +in many Perl community sites.

+ +
+

Your full name (civil name)

+

Unicode Characters OK.

+

+<%= text_field "pause99_request_id_fullname", size => 32 %> +

+
+Note: You can enter fairly free-form text here but it must consist of at least two space-separated words. This is a spam protection measure we discovered accidentally. Back when PAUSE was developed in the nineties, people would generally fill out a field asking for a full name with a first name and a second name, like Ben Cartwright or Tony Nelson. When this trivial expectation was coded into the server as a sanity check, it turned out to block many spam bots because they often did not try to enter a space in the middle of the field. It was only around 2003 that people started complaining that they had tried Peter and it did not work. Apologies for insisting, Peter – but feel free to make something up to satisfy the requirement. +
+
+ +
+

Email

+

required, otherwise we cannot send you the password

+

+<%= text_field "pause99_request_id_email", size => 32 %> +

+
+ +
+

Web site

+

optional

+

+<%= text_field "pause99_request_id_homepage", size => 32 %> +

+
+ +
+

Desired ID

+

3-9 characters matching [A-Z], please

+<%= text_field "pause99_request_id_userid", size => 32 %> +
+ +
+

A short description of why you would like a +PAUSE ID:

required; include what you are planning to contribute; do not use HTML

+ +<%= text_area "pause99_request_id_rationale", rows=>8, cols=>60 =%> + +

+ +% if ( $PAUSE::Config->{RECAPTCHA_ENABLED} ) { +% if ( $PAUSE::Config->{RECAPTCHA_SITE_KEY} ) { +
+
+
+ +% } +% else { +% warn "request_id: RECAPTCHA_SITE_KEY not available\n"; +% } +% } +
If you're a bot, then type something in here:
+

+ diff --git a/lib/pause_2025/templates/public/request_id/request.html.ep b/lib/pause_2025/templates/public/request_id/request.html.ep new file mode 100644 index 000000000..756318212 --- /dev/null +++ b/lib/pause_2025/templates/public/request_id/request.html.ep @@ -0,0 +1,48 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + +% if (@{$pause->{errors} || []}) { +

Error processing form

+% for (@{$pause->{errors}}) { +
  • <%= $_ %>
+% } +

Please retry.

+% } + +% if ($pause->{showform}) { + +%= include "public/request_id/_form"; + +% } +% if ($pause->{reg_ok}) { +% if ($pause->{recaptcha_enabled}) { +% if ($pause->{added_user}) { +

New user creation succeeded.

+ +

LOOK FOR AN EMAIL WITH YOUR TEMPORARY PASSWORD.

+ +

You'll also receive a welcome email like the one below.

+ + +
+% } else { +

New user creation failed.

+% } +% } +% elsif ($pause->{blurbcopy}) { +Sending mail to: <%= $pause->{send_to} %> + +
+ +% } +% } diff --git a/lib/pause_2025/templates/root/index.html.ep b/lib/pause_2025/templates/root/index.html.ep new file mode 100644 index 000000000..0e6778c09 --- /dev/null +++ b/lib/pause_2025/templates/root/index.html.ep @@ -0,0 +1,34 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; +% my $mgr = $c->app->pause; +% if ($pause->{User}{fullname}) { +

Hi <%= $pause->{User}{fullname} %>,
please choose an action from the menu.

+% } else { +

Please choose an action from the menu.

+% } + +

The usermenu to the left shows all menus available to +you, the table below shows descriptions for all menues available +to anybody on PAUSE.

+ +% my $alter = 1; + + +
+ + +% for my $group ($mgr->config->all_groups) { + % my @names = $mgr->config->action_names_for($group); + % for my $action ($mgr->config->sort_allowed_group_actions($group, \@names)) { + % next if defined $action->{display} and !$action->{display}; + + + + + + % } +% } +
ActionGroupDescription
<%= $action->{verb} %><%= b($action->{priv} || "N/A") %><%= b($action->{desc} || "N/A") %>
+
+ + diff --git a/lib/pause_2025/templates/user/change_passwd.html.ep b/lib/pause_2025/templates/user/change_passwd.html.ep new file mode 100644 index 000000000..bc8695d4f --- /dev/null +++ b/lib/pause_2025/templates/user/change_passwd.html.ep @@ -0,0 +1,43 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + + + +

Changing Password of <%= $pause->{HiddenUser}{userid} %>

+% if (param("ABRA")) { +"> +% } + +% if ($pause->{password_stored}) { +

New password stored and enabled. Be prepared that +you will be asked for a new authentication on the next request. If +this doesn't work out, it may be that you have to restart the +browser.

+% } else { +% if ( $pause->{UserSecrets}{forcechange} ) { + +

Your password in the database is tainted which +means you have to renew it. If you believe this is wrong, please +complain, it's always possible that you are seeing a bug.

+ +% } + +

Please fill in your new password in both textboxes. +Only if both fields contain the same password, we will be able to +proceed.

+ +<%= password_field "pause99_change_passwd_pw1", + maxlength => 72, + size => 16, +=%> + +<%= password_field "pause99_change_passwd_pw2", + maxlength => 72, + size => 16, +=%> + +%= csrf_field + + +% } + diff --git a/lib/pause_2025/templates/user/cred/edit.html.ep b/lib/pause_2025/templates/user/cred/edit.html.ep new file mode 100644 index 000000000..6d020e443 --- /dev/null +++ b/lib/pause_2025/templates/user/cred/edit.html.ep @@ -0,0 +1,151 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; +% my $cpan_alias = lc($pause->{HiddenUser}{userid}) . '@cpan.org'; + + + +

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

+ +% if (param("pause99_edit_cred_sub")) { +% if (my $error = $pause->{error}) { +
+ERROR: +% if ($error->{no_email}) { +Both of your email fields are left blank, this is not the way it is intended on PAUSE, PAUSE must be able to contact you. Please fill out at least one of the two email fields. +% } elsif ($error->{no_public_email}) { +You chose your email alias on CPAN to point to your public email address but your public email address is left blank. Please either pick a different choice for the alias or fill in a public email address. +% } elsif ($error->{public_is_cpan_alias}) { +You chose your email alias on CPAN to point to your public email address but your public email address field contains <%= $cpan_alias %>. This looks like a circular reference. Please either pick a different choice for the alias or fill in a more reasonable public email address. +% } elsif ($error->{no_secret_email}) { +You chose your email alias on CPAN to point to your secret email address but your secret email address is left blank. Please either pick a different choice for the alias or fill in a secret email address. +% } elsif ($error->{secret_is_cpan_alias}) { +You chose your email alias on CPAN to point to your secret email address but your secret email address field contains <%= $cpan_alias %>. This looks like a circular reference. Please either pick a different choice for the alias or fill in a more reasonable secret email address. +% } elsif ($error->{invalid_secret}) { +Your secret email address doesn't look like valid email address. +% } elsif ($error->{invalid_public}) { +Your public email address doesn't look like valid email address. +% } elsif ($error->{not_ascii}) { +Your asciiname seems to contain non-ascii characters. +% } +
+
+% } +% } + +% if ($pause->{consistentsubmit}) { +% for my $table ("users", $PAUSE::Config->{AUTHEN_USER_TABLE}) { +% if ($pause->{registered}{$table}) { +
+The new data are registered in table <%= $table %>. +
+
+ +% } +% } +% if (!$pause->{saw_a_change}) { +
+No change seen, nothing done. +
+
+% } +% } + +
+ +% my $alter = 0; + + + + + + + + + + + + +% if ($pause->{HiddenUser}{ustatus} ne "active") { + +% } + +

Full Name

+

+PAUSE supports names containing UTF-8 characters. +See also the field ASCII transliteration below. +

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

ASCII transliteration of Full Name

+

+If your Full Name contains +characters above 0x7f, please supply an +ASCII transliteration that can be used in +mail written in ASCII. Leave empty if you +trust the Text::Unidecode module. +

+<%= text_field "pause99_edit_cred_asciiname", + size => 50, + maxlength => 255, +%> +

Publicly visible email address (published in many listings)

+<%= text_field "pause99_edit_cred_email", + size => 50, + maxlength => 255, +%> +

Secret email address only used by the PAUSE, never published.

+

+If you leave this field empty, +PAUSE will use the public email address +for communicating with you. +

+<%= text_field "pause99_edit_cred_secretemail", + size => 50, + maxlength => 255, +%> +

Homepage or any contact URL except mailto:

+<%= text_field "pause99_edit_cred_homepage", + size => 50, + maxlength => 255, +%> +

The email address <%= $cpan_alias %> should be configured to forward mail to ...

+

+cpan.org has a mail +address for you and it's your choice if you want it to point to your +public email address or to your secret one. Please allow a few hours +for any change you make to this setting for propagation. BTW, let us +reassure you that cpan.org gets the data through a secure +channel.

Note: you can disable redirect by clicking +neither nor or by using an invalid email address in the +according field above, but this will prevent you from recieving +emails from services like rt.cpan.org. +

+<%= radio_button "pause99_edit_cred_cpan_mail_alias" => "publ" %> +my public email address
+<%= radio_button "pause99_edit_cred_cpan_mail_alias" => "secr" %> +my secret email address
+<%= radio_button "pause99_edit_cred_cpan_mail_alias" => "none", + checked => "checked", +%> neither nor
+

Remove account?

+

+You have not yet uploaded any files +to the CPAN, so your account can still be +cancelled. If you want to retire your +account, please click here. If you do +this, your account will not be removed +immediately but instead be removed +manually by the database maintainer at a +later date. +

+<%= check_box pause99_edit_cred_ustatus => "delete" %> +Account can be removed +
+%= csrf_field + diff --git a/lib/pause_2025/templates/user/distperms/giveup_dist_comaint.html.ep b/lib/pause_2025/templates/user/distperms/giveup_dist_comaint.html.ep new file mode 100644 index 000000000..2e64cf7d4 --- /dev/null +++ b/lib/pause_2025/templates/user/distperms/giveup_dist_comaint.html.ep @@ -0,0 +1,75 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + + + +% if (param("SUBMIT_pause99_giveup_dist_comaint")) { +
+% if ($pause->{error}) { +

<%= $pause->{error} %>

+% } elsif (@{$pause->{results} || []}) { +
    +% for (@{$pause->{results}}) { +% if ($_->{error}) { +
  • Error trying to remove <%= $_->{user} %> from co-maintainers of <%= $_->{mod} %> (<%= $_->{dist} %>): <%= $_->{error} %>
    • +% } else { +
  • Removed <%= $_->{user} %> from co-maintainers of <%= $_->{mod} %> (<%= $_->{dist} %>).
    • +% } +% } +
+% } else { +

You need to select one or more distributions. Nothing done.

+% } +
+
+% } + +% if (@{$pause->{dists} || []}) { +

Give up co-maintainer status

+

Please select one or +more distributions for which you want to be removed from +the co-maintainer table and press Give Up

+ +

If you need finer control (eg. to give up comaintainership +for a removed module), visit + +Give up Co-maintainership status per module page.

+ +

Select one or more distributions:

+ +
+ + + + + + + + + + + % for (@{$pause->{dists}}) { + + + + + + % } + +
DistributionOwners
<%= check_box "pause99_giveup_dist_comaint_d" => $_->[0] %><%= $_->[0] %><% if ($_->[1] =~ /,/) { %> (incomplete ownership)<% } %><%= $_->[1] %>
+

+

+
+% content_for javascript => begin +%= javascript "/list.min.js" +%= javascript begin +var List = new List('dists', { + valueNames: ['dist','owners'] +}); +% end +% end + +% } else { +

Sorry, <%= $pause->{HiddenUser}{userid} || $pause->{User}{userid} %> does not seem to be co-maintainer of any distribution.

+% } diff --git a/lib/pause_2025/templates/user/distperms/make_dist_comaint.html.ep b/lib/pause_2025/templates/user/distperms/make_dist_comaint.html.ep new file mode 100644 index 000000000..ae228259a --- /dev/null +++ b/lib/pause_2025/templates/user/distperms/make_dist_comaint.html.ep @@ -0,0 +1,92 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + + + +% if (param("SUBMIT_pause99_make_dist_comaint")) { +
+% if ($pause->{error}) { +

<%= $pause->{error} %>

+% } elsif (@{$pause->{results} || []}) { +
    +% for (@{$pause->{results}}) { +% if ($_->{error}) { +
  • Error trying to add <%= $_->{user} %> to co-maintainers of <%= $_->{mod} %> (<%= $_->{dist} %>): <%= $_->{error} %>
    • +% } elsif ($_->{duplicated}) { +
  • <%= $_->{user} %> was already a co-maintainer of <%= $_->{mod} %> (<%= $_->{dist} %>): skipping
    • +% } else { +
  • Added <%= $_->{user} %> to co-maintainers of <%= $_->{mod} %> (<%= $_->{dist} %>).
    • +% } +% } +
+% } else { +

You need to select one or more distributions and enter a userid. + Nothing done.

+% } +
+
+% } + +% if (@{$pause->{dists} || []}) { + +

Select a co-maintainer

+

Please select one or +more distributions for which you want to select a +co-maintainer, enter the CPAN userid of the co-maintainer +into the text field and press Make Co-Maintainer

+ +

If you are open to someone else asking for your first-come +permissions, but you wish to decide on any such request, you +can give a co-maint to a special user called +HANDOFF.

+ +

You can also grant co-maint to +NEEDHELP +if you would like additional volunteers to help you work on a particular module.

+ +

If you need finer control (eg. to add comaintainers for only +a small part of a distribution just to allow them to handle RT tickets +while prohibiting them to upload the distribution), visit + +Add Comaintainers per module page.

+ +

Select one or more distributions:

+
+ + + + + + + + + + + % for (@{$pause->{dists}}) { + + + + + + % } + +
DistributionOwners
<%= check_box "pause99_make_dist_comaint_d" => $_->[0] %><%= $_->[0] %><% if (($_->[1] // '') =~ /,/) { %> (incomplete ownership)<% } %><%= $_->[1] %>
+

Select a userid:
+<%= text_field "pause99_make_dist_comaint_a", size => 15, maxlength => 9 %> + +

+

+
+% content_for javascript => begin +%= javascript "/list.min.js" +%= javascript begin +var List = new List('dists', { + valueNames: ['dist','owners'] +}); +% end +% end + +% } else { +

Sorry, there are no distributions registered belonging to <%= $pause->{HiddenUser}{userid} || $pause->{User}{userid} %>.

+% } diff --git a/lib/pause_2025/templates/user/distperms/move_dist_primary.html.ep b/lib/pause_2025/templates/user/distperms/move_dist_primary.html.ep new file mode 100644 index 000000000..36c1441a2 --- /dev/null +++ b/lib/pause_2025/templates/user/distperms/move_dist_primary.html.ep @@ -0,0 +1,87 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + + + +% if (param("SUBMIT_pause99_move_dist_primary")) { +
+% if ($pause->{error}) { +

<%= $pause->{error} %>

+% } elsif (@{$pause->{results} || []}) { +
    +% for my $res (@{$pause->{results}}) { +% if ($res->{error}) { +
  • Error trying to make <%= $res->{user} %> primary maintainer of <%= $res->{mod} %> (<%= $res->{dist} %>): <%= $res->{error} %>
    • "; +% } else { +
  • Made <%= $res->{user} %> primary maintainer of <%= $res->{mod} %> (<%= $res->{dist} %>).
    • +% } +% } +
+% } else { +

You need to select one or more distributions and enter a userid. +Nothing done.

+% } +
+
+% } + +% if (@{$pause->{dists} || []}) { +

Pass maintainership status

Please select one +or more distributions for which you want to pass primary +maintainership status, enter the CPAN userid of the new +maintainer into the text field and press Pass Maintainership +Status. Note: you keep co-maintainer status after this move. +If you want to get rid of that too, please visit Give up +co-maintainership status next.

+ +

You can only transfer what you actually own. +If multiple owners are listed, you (or the person you are going to +transfer the distribution) need to ask those owners to transfer +their permissions as well.

+ +

If you need finer control (eg. to transfer only a small part of +a distribution you and other people own, for clarity's sake), visit + +Transfer Primary Permissions per module page.

+ +

Select one or more distributions:

+

+ + + + + + + + + + + % for (@{$pause->{dists}}) { + + + + + + % } + +
DistributionOwners
<%= check_box "pause99_move_dist_primary_d" => $_->[0] %><%= $_->[0] %><% if ($_->[1] =~ /,/) { %> (incomplete ownership)<% } %><%= $_->[1] %>
+

Select a userid:
+<%= text_field "pause99_move_dist_primary_a", size => 15, maxlength => 9 =%> +

+

+ +
+% content_for javascript => begin +%= javascript "/list.min.js" +%= javascript begin +var List = new List('dists', { + valueNames: ['dist', 'owners'] +}); +% end +% end + +% } else { +

Sorry, there are no distributions registered belonging to <%= $pause->{HiddenUser}{userid} || $pause->{User}{userid} %>.

+% } + diff --git a/lib/pause_2025/templates/user/distperms/peek.html.ep b/lib/pause_2025/templates/user/distperms/peek.html.ep new file mode 100644 index 000000000..132e6c29e --- /dev/null +++ b/lib/pause_2025/templates/user/distperms/peek.html.ep @@ -0,0 +1,113 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + +

Query the perms table by author or by +distribution. Select the option and fill in a distribution name or +user ID as appropriate. The answer is all distributions that an +user ID is registered for or all user IDs registered for a +distribution, as appropriate.

+ +

Registration comes in one of two types: type +first-come is the automatic registration on a +first-come-first-serve basis that happens on the initial +upload. And type co-maint is the registration as +co-maintainer which means that the primary maintainer of +the namespace has granted permission to upload this module +to other userid(s). Per namespace there can only be one +primary maintainer (userid in the +first-come category) and any number of userids in +the co-maint category. Being registered in any of +the categories means that a user is able not only to +upload a module in that namespace but also be accepted by +the indexer. In other words, the indexer will not ignore +uploads for that namespace by that person.

+ +

Permission is granted per namespace, +not per distribution. So you might not have enough +permission to upload a distribution or grant permissions to +other people if you are listed here (when you have permissions for +only a part of the distribution). If you want more detailed +information, visit +View permission per module page.

+ +

The +contents of the tables presented on this page are mostly +generated automatically, so please report any errors you +observe to <%= "@{$PAUSE::Config->{ADMINS}}" %> so that the tables +can be corrected.--Thank you!

+ +<%= select_field 'pause99_peek_dist_perms_by' => [ + ["for a distribution--exact match" => "de"], + [qq{for a distribution--SQL "LIKE" match} => "dl"], + ["of an author" => "a"], +], size => 1 =%> + +<%= text_field 'pause99_peek_dist_perms_query', size => 44, maxlength => 112, =%> + + + +

+% if (@{$pause->{rows} || []}) { +
+ + + + +% for (@{$pause->{column_names}}) { + +% } + + + +% for my $row (@{$pause->{rows}}) { + + + + + +% } + +
<%= $_ %>
$row->[0], + pause99_peek_dist_perms_sub => 1, + ]) %>"><%= $row->[0] %> +% my @owners = split /,/, $row->[1] // ''; +% while(my $owner = shift @owners) { + $owner, + pause99_peek_dist_perms_sub => 1, + ]) %>"><%= $owner %><% if (@owners) { %>,<% } %> +% } + +% my @comaints = split /,/, $row->[2] // ''; +% while(my $comaint = shift @comaints) { + $comaint, + pause99_peek_dist_perms_sub => 1, + ]) %>"><%= $comaint %><% if (@comaints) { %>,<% } %> +% } +
+

1, + pause99_peek_dist_perms_by => param("pause99_peek_dist_perms_by"), + pause_peek_dist_perms_query => param("pause99_peek_dist_perms_query")], +) %>" style="text-decoration: none;"> +YAML +

+
+% content_for javascript => begin +%= javascript "/list.min.js" +%= javascript begin +var List = new List('perms', { + valueNames: ['dist', 'owner', 'comaint'] +}); +% end +% end + +% } else { +No records found. +% } diff --git a/lib/pause_2025/templates/user/distperms/remove_dist_comaint.html.ep b/lib/pause_2025/templates/user/distperms/remove_dist_comaint.html.ep new file mode 100644 index 000000000..09ccc3d2a --- /dev/null +++ b/lib/pause_2025/templates/user/distperms/remove_dist_comaint.html.ep @@ -0,0 +1,79 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + + + +% if (param("SUBMIT_pause99_remove_dist_comaint")) { +
+% if ($pause->{error}) { +

<%= $pause->{error} %>

+% } elsif (@{$pause->{results} || []}) { +
    +% for (@{$pause->{results}}) { +% if ($_->{not_exists}) { +
  • Cannot handle tuple <%= $_->{sel} %>. If you believe, this is a bug, please complain.
    • +% } elsif ($_->{error}) { +
  • Error trying to remove <%= $_->{user} %> from co-maintainers of <%= $_->{mod} %> (<%= $_->{dist} %>): <%= $_->{error} %>
    • +% } else { +
  • Removed <%= $_->{user} %> from co-maintainers of <%= $_->{mod} %> (<%= $_->{dist} %>).
    • +% } +% } +
+% } else { +

You need to select one or more distributions. Nothing done.

+% } +
+
+% } + +% if (@{$pause->{dists} || []}) { +

Remove co-maintainer status

+

The scrolling +list shows you, which distributions are associated with other +maintainers besides yourself. Every line denotes a tuple +of a distribution and a userid. Select those that you want to +remove and press Remove

+ +

If you need finer control (eg. to remove comaintainers +only for a small part of a distribution, or remove comaintainers +for a removed module), visit + +Remove Comaintainers per module page.

+ +
+ + + + + + + + + + + % for (@{$pause->{dists}}) { + % my ($dist, $userid) = split /\s*\-\-\s*/, $_; + + + + + + % } + +
DistributionUserID
<%= check_box "pause99_remove_dist_comaint_tuples" => $_ %><%= $dist %><%= $userid %>
+

+

+
+% content_for javascript => begin +%= javascript "/list.min.js" +%= javascript begin +var List = new List('dists', { + valueNames: ['dist', 'userid'] +}); +% end +% end + +% } else { +

There are no co-maintainers registered to any of <%= $pause->{HiddenUser}{userid} || $pause->{User}{userid} %>'s distributions.

+% } diff --git a/lib/pause_2025/templates/user/distperms/remove_dist_primary.html.ep b/lib/pause_2025/templates/user/distperms/remove_dist_primary.html.ep new file mode 100644 index 000000000..670c18667 --- /dev/null +++ b/lib/pause_2025/templates/user/distperms/remove_dist_primary.html.ep @@ -0,0 +1,96 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + + + +% if (param("SUBMIT_pause99_remove_dist_primary")) { +
+% if ($pause->{error}) { +

<%= $pause->{error} %>

+% } elsif (@{$pause->{results} || []}) { +
    +% for (@{$pause->{results}}) { +% if ($_->{error}) { +
  • Error trying to remove primary maintainership of <%= $_->{user} %> from <%= $_->{mod} %> (<%= $_->{dist} %>): <%= $_->{error} %>
    • +% } else { +
  • Removed primary maintainership of <%= $_->{user} %> from <%= $_->{mod} %> (<%= $_->{dist} %>).
    • +% } +% } +
+% } else { +

You need to select one or more distributions. Nothing done.

+% } +
+
+% } + +% if (@{$pause->{dists} || []}) { + +

Give up maintainership status

+

Please select one or more distributions for which you +want to give up primary maintainership status and press +Give Up Maintainership Status. Note: you keep co-maintainer +status after this move. If you want to get rid of that too, +please visit ">Give up +co-maintainership status next.

+ +

Giving up primary permissions now means that the permissions are +transferred to a special user called +ADOPTME. +

+ +

You can only give up what you actually own. +If multiple owners are listed, those owners keep their primary +maintainership for their part of the distribution. In this case, +you are strongly advised to +">transfer your primary permissions +to one of the other owners.

+ +

+If you have are unsure about what to do, or have any questions, +please email the PAUSE admins at modules@cpan.org. +

+ +

If you need finer control (eg. to give up only a small part of +a distribution for whatever reasons), visit + +<%= $c->app->pause->config->action('remove_primary')->{verb} %> page.

+ +

Select one or more distributions:

+
+ + + + + + + + + + + % for (@{$pause->{dists}}) { + + + + + + % } + +
DistributionOwners
<%= check_box "pause99_remove_dist_primary_d" => $_->[0] %><%= $_->[0] %><% if ($_->[1] =~ /,/) { %> (incomplete ownership)<% } %><%= $_->[1] %>
+ +

+
+% content_for javascript => begin +%= javascript "/list.min.js" +%= javascript begin +var List = new List('dists', { + valueNames: ['dist', 'owners'] +}); +% end +% end + +% } else { +

Sorry, there are no distributions registered belonging to <%= $pause->{HiddenUser}{userid} || $pause->{User}{userid} %>.

+% } + diff --git a/lib/pause_2025/templates/user/edit_uris.html.ep b/lib/pause_2025/templates/user/edit_uris.html.ep new file mode 100644 index 000000000..baf4724bb --- /dev/null +++ b/lib/pause_2025/templates/user/edit_uris.html.ep @@ -0,0 +1,83 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + + +

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

+ +% if ($pause->{no_pending_uploads}) { +

No pending uploads for <%= $pause->{HiddenUser}{userid} %> found

+% } else { + +<%= select_field "pause99_edit_uris_3" => $pause->{all_recs}, + size => 1, +%> + +
+ +% if (%{$pause->{selected}}) { +

Record for <%= $pause->{selected}{uriid} %>

+ +% if ($pause->{changed}) { +

The record has been updated in the database

+% } elsif ($pause->{update_sel}) { +It seems to me the record was NOT updated. Maybe nothing has changed? +Please take a closer look and inform an admin if things didn't proceed as expected.
+% } + +

URI to download

+ +If you change this field to a different URI, +PAUSE will try to fetch this URI instead. Note that the +filename on PAUSE will remain unaltered. So you can fix a +typo, but you cannot alter the name of the uploaded file, it +will be the original filename. So this is only an opportunity +to fix broken uploads that cannot be completed, not an +opportunity to turn the time back. + +

To re-iterate: If you change the content of this field to +http://www.slashdot.org/, PAUSE will fetch the current +Slashdot page and will put it into +<%= $pause->{selected}{uriid} %>. If you change it to +FooBar-3.14.tar.gz, PAUSE will try to get +<%= $PAUSE::Config->{INCOMING} %>/FooBar-3.14.tar.gz and if it +finds it, it puts it into <%= $pause->{selected}{uriid} %>.

+ +

An example: if you made a typo and requested to upload +http://badsite.org/foo instead of +http://goodsite.org/foo, just correct the thing in the +textfield below.

+ +

Another example: If your upload was unsuccessful and you now have +a bad file in the incoming directory, then you have the +problem that PAUSE tries to fetch your file (say foo) +but doesn't succeed and then it retries and retries. Your +solution: transfer the file into the incoming directory with +a different name (say bar) using ftp. Fill in +the different name below. PAUSE will fetch bar and +upload it as foo. So you're done.

+
+ +<%= text_field "pause99_edit_uris_uri" => $pause->{selected}{uri}, + size => 60, + maxlength => 255, +%> +
+ +

UNIX time of last unsuccessful attempt to retrieve this item

+<%= $pause->{selected}{nosuccesstime} || 0 %>
+
+ +

Number of unsuccessful attempts so far

+<%= $pause->{selected}{nosuccesscount} || 0 %>
+
+ +

Record was last changed on

+<%= $pause->{selected}{changed} || 0 %>
+
+ +

Record was last changed by

+<%= $pause->{selected}{changedby} || 0 %>
+
+
+% } +% } diff --git a/lib/pause_2025/templates/user/files/delete.html.ep b/lib/pause_2025/templates/user/files/delete.html.ep new file mode 100644 index 000000000..6bd26d07d --- /dev/null +++ b/lib/pause_2025/templates/user/files/delete.html.ep @@ -0,0 +1,58 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; +% my $files = $pause->{files} || {}; + + +

Files in directory authors/id/<%= $pause->{userhome} %>

+ +% if (%$files) { +% if ($pause->{deleting_indexed_files}) { +
+

You are deleting one or more files that appear in the CPAN index.

+
+% } else { +
+

If you delete files marked with [indexed], the CPAN index will be affected.

+
+% } +
+ + + + + + + + + + + +% for my $file (sort keys %$files) { + + +% if ($files->{$file}{indexed}) { + +% } else { + +% } + + + +% } + +
FileSizeModified
<%= check_box "pause99_delete_files_FILE" => $file %><%= $file %> [indexed]<%= $file %><%= $files->{$file}{stat} %><%= $files->{$file}{blurb} %>
+ +

+
+% content_for javascript => begin +%= javascript "/list.min.js" +%= javascript begin +var List = new List('files', { + valueNames: ['file', 'size', 'modified'] +}); +% end +% end + +% } else { +No files found in authors/id/<%= $pause->{userhome} %> +% } diff --git a/lib/pause_2025/templates/user/files/show.html.ep b/lib/pause_2025/templates/user/files/show.html.ep new file mode 100644 index 000000000..9bab21d54 --- /dev/null +++ b/lib/pause_2025/templates/user/files/show.html.ep @@ -0,0 +1,43 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; +% my $files = $pause->{files} || {}; + +

Files in directory authors/id/<%= $pause->{userhome} %>

+% if (%$files) { +
+ + + + + + + + + + +% for my $file (sort keys %$files) { + +% if ($files->{$file}{indexed}) { + +% } else { + +% } + + + +% } + +
FileSizeModified
<%= $file %> [indexed]<%= $file %><%= $files->{$file}{stat} %><%= $files->{$file}{blurb} %>
+
+% content_for javascript => begin +%= javascript "/list.min.js" +%= javascript begin +var List = new List('files', { + valueNames: ['file', 'size', 'modified'] +}); +% end +% end + +% } else { +No files found in authors/id/<%= $pause->{userhome} %> +% } diff --git a/lib/pause_2025/templates/user/perms/_share_makeco.html.ep b/lib/pause_2025/templates/user/perms/_share_makeco.html.ep new file mode 100644 index 000000000..90f1f1ef7 --- /dev/null +++ b/lib/pause_2025/templates/user/perms/_share_makeco.html.ep @@ -0,0 +1,64 @@ +% my $pause = stash(".pause") || {}; + +% if (param("SUBMIT_pause99_share_perms_makeco")) { +
+% if ($pause->{error}) { +

<%= $pause->{error} %>

+% } elsif (@{$pause->{results} || []}) { +% for (@{$pause->{results}}) { +% if ($_->{error}) { +

Error trying to add <%= $_->{user} %> to co-maintainers of <%= $_->{mod} %>: <%= $_->{error} %>

+% } elsif ($_->{duplicated}) { +

<%= $_->{user} %> was already a co-maintainer of <%= $_->{mod} %>: skipping

+ +% } else { +

Added <%= $_->{user} %> to co-maintainers of <%= $_->{mod} %>.

+% } +% } +% } else { +

You need to select one or more packages and enter a userid. + Nothing done.

+% } +
+
+% } + +% if (@{$pause->{mods} || []}) { + +

Select a co-maintainer

+

Please select one or +more namespaces for which you want to select a +co-maintainer, enter the CPAN userid of the co-maintainer +into the text field and press Make Co-Maintainer

+ +

If you are open to someone else asking for your first-come +permissions, but you wish to decide on any such request, you +can give a co-maint to a special user called +HANDOFF.

+ +

You can also grant co-maint to +NEEDHELP +if you would like additional volunteers to help you work on a particular module.

+ +

If you want to add comaintainers for all the modules in a +distribution, visit +Add Comaintainers per distribution page.

+ +

Select one or more namespaces:

+ +<%= select_field "pause99_share_perms_makeco_m" => $pause->{mods}, + multiple => "multiple", + size => (@{$pause->{mods}} > 18 ? 15 : scalar @{$pause->{mods}}), +=%> + +

+

Select a userid:
+<%= text_field "pause99_share_perms_makeco_a", size => 15, maxlength => 9 %> + +

+

+ +% } else { +

Sorry, there are no modules registered belonging to <%= $pause->{HiddenUser}{userid} || $pause->{User}{userid} %>.

+% } diff --git a/lib/pause_2025/templates/user/perms/_share_movepr.html.ep b/lib/pause_2025/templates/user/perms/_share_movepr.html.ep new file mode 100644 index 000000000..862cbfd62 --- /dev/null +++ b/lib/pause_2025/templates/user/perms/_share_movepr.html.ep @@ -0,0 +1,52 @@ +% my $pause = stash(".pause") || {}; + +% if (param("SUBMIT_pause99_share_perms_movepr")) { +
+% if ($pause->{error}) { +

<%= $pause->{error} %>

+% } elsif (@{$pause->{results} || []}) { +% for my $res (@{$pause->{results}}) { +% if ($res->{error}) { +

Error trying to make <%= $res->{user} %> primary maintainer of <%= $res->{mod} %>: <%= $res->{error} %>

\n"; +% } else { +

Made <%= $res->{user} %> primary maintainer of <%= $res->{mod} %>.

+% } +% } +% } else { +

You need to select one or more packages and enter a userid. +Nothing done.

+% } +
+
+% } + +% if (@{$pause->{mods}}) { +

Pass maintainership status

Please select one +or more namespaces for which you want to pass primary +maintainership status, enter the CPAN userid of the new +maintainer into the text field and press Pass Maintainership +Status. Note: you keep co-maintainer status after this move. +If you want to get rid of that too, please visit Give up +co-maintainership status next.

+ +

If you want to transfer all the modules in a distribution, visit + +Transfer Primary Permissions per distribution page.

+ +

Select one or more namespaces:

+<%= select_field "pause99_share_perms_pr_m" => $pause->{mods}, + multiple => "multiple", + size => (@{$pause->{mods}} > 18 ? 15 : scalar @{$pause->{mods}}), +=%> + +

+

Select a userid:
+<%= text_field "pause99_share_perms_movepr_a", size => 15, maxlength => 9 =%> +

+

+ +% } else { +

Sorry, there are no modules registered belonging to <%= $pause->{HiddenUser}{userid} || $pause->{User}{userid} %>.

+% } + diff --git a/lib/pause_2025/templates/user/perms/_share_remocos.html.ep b/lib/pause_2025/templates/user/perms/_share_remocos.html.ep new file mode 100644 index 000000000..694d58ddf --- /dev/null +++ b/lib/pause_2025/templates/user/perms/_share_remocos.html.ep @@ -0,0 +1,48 @@ +% my $pause = stash(".pause") || {}; + +% if (param("SUBMIT_pause99_share_perms_remocos")) { +
+% if ($pause->{error}) { +

<%= $pause->{error} %>

+% } elsif (@{$pause->{results} || []}) { +% for (@{$pause->{results}}) { +% if ($_->{not_exists}) { +

Cannot handle tuple <%= $_->{mod} %>. If you believe, this is a bug, please complain.

+% } elsif ($_->{error}) { +

Error trying to remove <%= $_->{user} %> from co-maintainers of <%= $_->{mod} %>: <%= $_->{error} %>

+% } else { +

Removed <%= $_->{user} %> from co-maintainers of <%= $_->{mod} %>.

+% } +% } +% } else { +

You need to select one or more packages. Nothing done.

+% } +
+
+% } + +% if (@{$pause->{mods} || []}) { +

Remove co-maintainer status

+

The scrolling +list shows you, which packages are associated with other +maintainers besides yourself. Every line denotes a tuple +of a namespace and a userid. Select those that you want to +remove and press Remove

+ +

If you want to remove comaintainers from all the modules +in a distribution, visit + +Remove Comaintainers per distribution page.

+ +<%= select_field "pause99_share_perms_remocos_tuples" => $pause->{mods}, + multiple => "multiple", + size => (@{$pause->{mods}} > 18 ? 15 : scalar (@{$pause->{mods}})), +%> +

+

+

+ +% } else { +

There are no co-maintainers registered to any of <%= $pause->{HiddenUser}{userid} || $pause->{User}{userid} %>'s modules.

+% } diff --git a/lib/pause_2025/templates/user/perms/_share_remome.html.ep b/lib/pause_2025/templates/user/perms/_share_remome.html.ep new file mode 100644 index 000000000..39b8dee96 --- /dev/null +++ b/lib/pause_2025/templates/user/perms/_share_remome.html.ep @@ -0,0 +1,47 @@ +% my $pause = stash(".pause") || {}; + +% if (param("SUBMIT_pause99_share_perms_remome")) { +
+% if ($pause->{error}) { +

<%= $pause->{error} %>

+% } elsif (@{$pause->{results} || []}) { +% for (@{$pause->{results}}) { +% if ($_->{error}) { +

Error trying to remove <%= $_->{user} %> from co-maintainers of <%= $_->{mod} %>: <%= $_->{error} %>

+% } else { +

Removed <%= $_->{user} %> from co-maintainers of <%= $_->{mod} %>.

+% } +% } +% } else { +

You need to select one or more packages. Nothing done.

+% } +
+
+% } + +% if (@{$pause->{mods} || []}) { +

Give up co-maintainer status

+

Please select one or +more namespaces for which you want to be removed from +the co-maintainer table and press Give Up

+ +

If you want to give up comaintainership for all the modules +in a distribution, visit + +Give up Co-maintainership status per distribution page.

+ +

Select one or more namespaces:

+ +<%= select_field "pause99_share_perms_remome_m" => $pause->{mods}, + multiple => "multiple", + size => (@{$pause->{mods}} > 18 ? 15 : scalar @{$pause->{mods}}), +=%> + +

+

+

+ +% } else { +

Sorry, <%= $pause->{HiddenUser}{userid} || $pause->{User}{userid} %> does not seem to be co-maintainer of any module.

+% } diff --git a/lib/pause_2025/templates/user/perms/_share_remopr.html.ep b/lib/pause_2025/templates/user/perms/_share_remopr.html.ep new file mode 100644 index 000000000..3dbee1681 --- /dev/null +++ b/lib/pause_2025/templates/user/perms/_share_remopr.html.ep @@ -0,0 +1,50 @@ +% my $pause = stash(".pause") || {}; + +% if (param("SUBMIT_pause99_share_perms_remopr")) { +
+% if ($pause->{error}) { +

<%= $pause->{error} %>

+% } elsif (!@{$pause->{results} || []}) { +

You need to select one or more packages. Nothing done.

+% } else { +% for (@{$pause->{results}}) { +% if ($_->{error}) { +

Error trying to remove primary maintainership of <%= $_->{user} %> from <%= $_->{mod} %>: <%= $_->{error} %>

+% } else { +

Removed primary maintainership of <%= $_->{user} %> from <%= $_->{mod} %>.

+% } +% } +% } +
+
+% } + +% if (@{$pause->{mods} || []}) { + +

Give up maintainership status

+

Please select one or more namespaces for which you +want to give up primary maintainership status and press +Give Up Maintainership Status. Note: you keep co-maintainer +status after this move. If you want to get rid of that too, +please visit Give up +co-maintainership status next.

+ +

If you want to give up comaintainership for all the modules +in a distribution, visit + +Give up Co-maintainership status per distribution page.

+ +

Select one or more namespaces:

+<%= select_field "pause99_share_perms_pr_m" => $pause->{mods}, + multilple => "multiple", + size => (@{$pause->{mods}} > 18 ? 15 : scalar @{$pause->{mods}}), +=%> + +

+

+ +% } else { +

Sorry, there are no modules registered belonging to <%= $pause->{HiddenUser}{userid} || $pause->{User}{userid} %>.

+% } + diff --git a/lib/pause_2025/templates/user/perms/giveup_comaint.html.ep b/lib/pause_2025/templates/user/perms/giveup_comaint.html.ep new file mode 100644 index 000000000..a1d10c908 --- /dev/null +++ b/lib/pause_2025/templates/user/perms/giveup_comaint.html.ep @@ -0,0 +1,75 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + + + +% if (param("SUBMIT_pause99_share_perms_remome")) { +
+% if ($pause->{error}) { +

<%= $pause->{error} %>

+% } elsif (@{$pause->{results} || []}) { +
    +% for (@{$pause->{results}}) { +% if ($_->{error}) { +
  • Error trying to remove <%= $_->{user} %> from co-maintainers of <%= $_->{mod} %>: <%= $_->{error} %>
    • +% } else { +
  • Removed <%= $_->{user} %> from co-maintainers of <%= $_->{mod} %>.
    • +% } +% } +
+% } else { +

You need to select one or more packages. Nothing done.

+% } +
+
+% } + +% if (@{$pause->{mods} || []}) { +

Give up co-maintainer status

+

Please select one or +more namespaces for which you want to be removed from +the co-maintainer table and press Give Up

+ +

If you want to give up comaintainership for all the modules +in a distribution, visit + +Give up Co-maintainership status per distribution page.

+ +

Select one or more namespaces:

+ +
+ + + + + + + + + + + % for (@{$pause->{mods}}) { + + + + + + % } + +
PackageIndexed Distribution
<%= check_box "pause99_share_perms_remome_m" => $_ %><%= $_ %><%= $pause->{dist_for_package}{$_} // '' %>
+

+

+
+% content_for javascript => begin +%= javascript "/list.min.js" +%= javascript begin +var List = new List('packages', { + valueNames: ['package', 'dist'] +}); +% end +% end + +% } else { +

Sorry, <%= $pause->{HiddenUser}{userid} || $pause->{User}{userid} %> does not seem to be co-maintainer of any module.

+% } diff --git a/lib/pause_2025/templates/user/perms/make_comaint.html.ep b/lib/pause_2025/templates/user/perms/make_comaint.html.ep new file mode 100644 index 000000000..33cd2092b --- /dev/null +++ b/lib/pause_2025/templates/user/perms/make_comaint.html.ep @@ -0,0 +1,90 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + + + +% if (param("SUBMIT_pause99_share_perms_makeco")) { +
+% if ($pause->{error}) { +

<%= $pause->{error} %>

+% } elsif (@{$pause->{results} || []}) { +
    +% for (@{$pause->{results}}) { +% if ($_->{error}) { +
  • Error trying to add <%= $_->{user} %> to co-maintainers of <%= $_->{mod} %>: <%= $_->{error} %>
    • +% } elsif ($_->{duplicated}) { +
  • <%= $_->{user} %> was already a co-maintainer of <%= $_->{mod} %>: skipping
    • +% } else { +
  • Added <%= $_->{user} %> to co-maintainers of <%= $_->{mod} %>.
    • +% } +% } +
+% } else { +

You need to select one or more packages and enter a userid. + Nothing done.

+% } +
+
+% } + +% if (@{$pause->{mods} || []}) { + +

Select a co-maintainer

+

Please select one or +more namespaces for which you want to select a +co-maintainer, enter the CPAN userid of the co-maintainer +into the text field and press Make Co-Maintainer

+ +

If you are open to someone else asking for your first-come +permissions, but you wish to decide on any such request, you +can give a co-maint to a special user called +HANDOFF.

+ +

You can also grant co-maint to +NEEDHELP +if you would like additional volunteers to help you work on a particular module.

+ +

If you want to add comaintainers for all the modules in a +distribution, visit +Add Comaintainers per distribution page.

+ +

Select one or more namespaces:

+
+ + + + + + + + + + + % for (@{$pause->{mods}}) { + + + + + + % } + +
PackageIndexed Distribution
<%= check_box "pause99_share_perms_makeco_m" => $_ %><%= $_ %><%= $pause->{dist_for_package}{$_} %>
+

Select a userid:
+<%= text_field "pause99_share_perms_makeco_a", size => 15, maxlength => 9 %> + +

+

+
+% content_for javascript => begin +%= javascript "/list.min.js" +%= javascript begin +var List = new List('packages', { + valueNames: ['package', 'dist'] +}); +% end +% end + +% } else { +

Sorry, there are no modules registered belonging to <%= $pause->{HiddenUser}{userid} || $pause->{User}{userid} %>.

+% } diff --git a/lib/pause_2025/templates/user/perms/move_primary.html.ep b/lib/pause_2025/templates/user/perms/move_primary.html.ep new file mode 100644 index 000000000..faa112646 --- /dev/null +++ b/lib/pause_2025/templates/user/perms/move_primary.html.ep @@ -0,0 +1,81 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + + + +% if (param("SUBMIT_pause99_share_perms_movepr")) { +
+% if ($pause->{error}) { +

<%= $pause->{error} %>

+% } elsif (@{$pause->{results} || []}) { +
    +% for my $res (@{$pause->{results}}) { +% if ($res->{error}) { +
  • Error trying to make <%= $res->{user} %> primary maintainer of <%= $res->{mod} %>: <%= $res->{error} %>
    • "; +% } else { +
  • Made <%= $res->{user} %> primary maintainer of <%= $res->{mod} %>.
    • +% } +% } +
+% } else { +

You need to select one or more packages and enter a userid. +Nothing done.

+% } +
+
+% } + +% if (@{$pause->{mods}}) { +

Pass maintainership status

Please select one +or more namespaces for which you want to pass primary +maintainership status, enter the CPAN userid of the new +maintainer into the text field and press Pass Maintainership +Status. Note: you keep co-maintainer status after this move. +If you want to get rid of that too, please visit Give up +co-maintainership status next.

+ +

If you want to transfer all the modules in a distribution, visit + +Transfer Primary Permissions per distribution page.

+ +

Select one or more namespaces:

+

+ + + + + + + + + + + % for (@{$pause->{mods}}) { + + + + + + % } + +
PackageIndexed Distribution
<%= check_box "pause99_share_perms_pr_m" => $_ %><%= $_ %><%= $pause->{dist_for_package}{$_} // '' %>
+

Select a userid:
+<%= text_field "pause99_share_perms_movepr_a", size => 15, maxlength => 9 =%> +

+

+ +
+% content_for javascript => begin +%= javascript "/list.min.js" +%= javascript begin +var List = new List('packages', { + valueNames: ['package', 'dist'] +}); +% end +% end + +% } else { +

Sorry, there are no modules registered belonging to <%= $pause->{HiddenUser}{userid} || $pause->{User}{userid} %>.

+% } + diff --git a/lib/pause_2025/templates/user/perms/peek.html.ep b/lib/pause_2025/templates/user/perms/peek.html.ep new file mode 100644 index 000000000..d0d0d5ea8 --- /dev/null +++ b/lib/pause_2025/templates/user/perms/peek.html.ep @@ -0,0 +1,95 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + +

Query the perms table by author or by +module. Select the option and fill in a module name or +user ID as appropriate. The answer is all modules that an +user ID is registered for or all user IDs registered for a +module, as appropriate.

+ +

Registration comes in one of two types: type +first-come is the automatic registration on a +first-come-first-serve basis that happens on the initial +upload. And type co-maint is the registration as +co-maintainer which means that the primary maintainer of +the namespace has granted permission to upload this module +to other userid(s). Per namespace there can only be one +primary maintainer (userid in the +first-come category) and any number of userids in +the co-maint category. Being registered in any of +the categories means that a user is able not only to +upload a module in that namespace but also be accepted by +the indexer. In other words, the indexer will not ignore +uploads for that namespace by that person.

+ +

If the list is too long, visit +View permission per distribution page.

+ +

The +contents of the tables presented on this page are mostly +generated automatically, so please report any errors you +observe to <%= "@{$PAUSE::Config->{ADMINS}}" %> so that the tables +can be corrected.--Thank you!

+ +<%= select_field 'pause99_peek_perms_by' => [ + ["for a module--exact match" => "me"], + [qq{for a module--SQL "LIKE" match} => "ml"], + ["of an author" => "a"], +], size => 1 =%> + +<%= text_field 'pause99_peek_perms_query', size => 44, maxlength => 112, =%> + + + +

+% if (@{$pause->{rows} || []}) { + +% content_for javascript => begin +%= javascript "/list.min.js" +%= javascript begin +var List = new List('perms', { + valueNames: ['module', 'userid', 'type', 'owner'] +}); +% end +% end + +% } else { +No records found. +% } diff --git a/lib/pause_2025/templates/user/perms/remove_comaint.html.ep b/lib/pause_2025/templates/user/perms/remove_comaint.html.ep new file mode 100644 index 000000000..3cc4eeb72 --- /dev/null +++ b/lib/pause_2025/templates/user/perms/remove_comaint.html.ep @@ -0,0 +1,80 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + + + +% if (param("SUBMIT_pause99_share_perms_remocos")) { +
+% if ($pause->{error}) { +

<%= $pause->{error} %>

+% } elsif (@{$pause->{results} || []}) { +
    +% for (@{$pause->{results}}) { +% if ($_->{not_exists}) { +
  • Cannot handle tuple <%= $_->{mod} %>. If you believe, this is a bug, please complain.
    • +% } elsif ($_->{error}) { +
  • Error trying to remove <%= $_->{user} %> from co-maintainers of <%= $_->{mod} %>: <%= $_->{error} %>
    • +% } else { +
  • Removed <%= $_->{user} %> from co-maintainers of <%= $_->{mod} %>.
    • +% } +% } +
+% } else { +

You need to select one or more packages. Nothing done.

+% } +
+
+% } + +% if (@{$pause->{mods} || []}) { +

Remove co-maintainer status

+

The scrolling +list shows you, which packages are associated with other +maintainers besides yourself. Every line denotes a tuple +of a namespace and a userid. Select those that you want to +remove and press Remove

+ +

If you want to remove comaintainers from all the modules +in a distribution, visit + +Remove Comaintainers per distribution page.

+ +
+ + + + + + + + + + + + % for (@{$pause->{mods}}) { + % my ($package, $userid) = split /\s*\-\-\s*/, $_; + + + + + + + % } + +
PackageIndexed DistributionUserID
<%= check_box "pause99_share_perms_remocos_tuples" => $_ %><%= $package %><%= $pause->{dist_for_package}{$package} // '' %><%= $userid %>
+

+

+
+% content_for javascript => begin +%= javascript "/list.min.js" +%= javascript begin +var List = new List('packages', { + valueNames: ['pacakge', 'dist', 'userid'] +}); +% end +% end + +% } else { +

There are no co-maintainers registered to any of <%= $pause->{HiddenUser}{userid} || $pause->{User}{userid} %>'s modules.

+% } diff --git a/lib/pause_2025/templates/user/perms/remove_primary.html.ep b/lib/pause_2025/templates/user/perms/remove_primary.html.ep new file mode 100644 index 000000000..778a7cd0a --- /dev/null +++ b/lib/pause_2025/templates/user/perms/remove_primary.html.ep @@ -0,0 +1,92 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + + + +% if (param("SUBMIT_pause99_share_perms_remopr")) { +
+% if ($pause->{error}) { +

<%= $pause->{error} %>

+% } elsif (@{$pause->{results} || []}) { +
    +% for (@{$pause->{results}}) { +% if ($_->{error}) { +
  • Error trying to remove primary maintainership of <%= $_->{user} %> from <%= $_->{mod} %>: <%= $_->{error} %>
    • +% } else { +
  • Removed primary maintainership of <%= $_->{user} %> from <%= $_->{mod} %>.
    • +% } +% } +
+% } else { +

You need to select one or more packages. Nothing done.

+% } +
+
+% } + +% if (@{$pause->{mods} || []}) { + +

Give up maintainership status

+

Please select one or more namespaces for which you +want to give up primary maintainership status and press +Give Up Maintainership Status. Note: you keep co-maintainer +status after this move. If you want to get rid of that too, +please visit ">Give up +co-maintainership status next.

+ +

Giving up primary permissions now means that the permissions are +transferred to a special user called +ADOPTME.

+ +

If multiple owners are listed, those owners keep their primary +maintainership for those modules. In this case, you are strongly advised to +">transfer your primary permissions +to one of the other owners.

+ +

+If you have are unsure about what to do, or have any questions, +please email the PAUSE admins at modules@cpan.org. +

+ +

If you want to give up all the modules in a distribution, visit + +<%= $c->app->pause->config->action('remove_dist_primary')->{verb} %> page.

+ +

Select one or more namespaces:

+
+ + + + + + + + + + + % for (@{$pause->{mods}}) { + + + + + + % } + +
PackageIndexed Distribution
<%= check_box "pause99_share_perms_pr_m" => $_ %><%= $_ %><%= $pause->{dist_for_package}{$_} // '' %>
+ +

+
+% content_for javascript => begin +%= javascript "/list.min.js" +%= javascript begin +var List = new List('packages', { + valueNames: ['package', 'dist'] +}); +% end +% end + +% } else { +

Sorry, there are no modules registered belonging to <%= $pause->{HiddenUser}{userid} || $pause->{User}{userid} %>.

+% } + diff --git a/lib/pause_2025/templates/user/perms/share.html.ep b/lib/pause_2025/templates/user/perms/share.html.ep new file mode 100644 index 000000000..061ed849c --- /dev/null +++ b/lib/pause_2025/templates/user/perms/share.html.ep @@ -0,0 +1,159 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; +% my $subaction = $pause->{subaction} || ""; + + + + +% unless ($subaction) { +

Permissions on PAUSE come in three flavors:

+
    +
  • + only one user per module can be either +
    +
      +
    • + registered in modulelist or +
      • +
    • + primary maintainer on a first-come-first-serve + basis; +
      • +
    +
    • +
  • + many users can get granted permissions as co-maintainers, + which means their uploads for the given module are honoured by + the indexer. +
    • +
+ +

You can view your current set of permissions on the View Permissions page. To + change permissions, select one of the following submit + buttons, each of which leads you to a different page:

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+ 1. You are registered in modulelist +
+% if (my @mods = @{$pause->{mods} || []}) { +<%= select_field "pause99_edit_mod_3" => \@mods, size => (@mods > 18 ? 15 : scalar @mods) %> +% } else { +--NONE-- +% } + + + Module Metadata has been removed from PAUSE and + is no longer editable. Please contact a PAUSE administrator to + choose a new owner. +
2. You are primary maintainer:
+% if (my @mods = @{$pause->{remove_primary} || []}) { +<%= select_field "pause99_share_perms_pr_m" => \@mods, size => (@mods > 18 ? 15 : scalar @mods), multiple => "multiple" %> +% } else { +--NONE-- +% } + + + + 2.1 Transfer primary maintainership status to somebody else + (you become co-maintainer) +
+ + + 2.2 Give up primary maintainership status (abandoning it without + transfering it to someone else) +
+ 3. Making and unmaking co-maintainers (for both modulelist + owners and primary maintainers): +
+% if (my @mods = @{$pause->{make_comaintainer} || []}) { +<%= select_field "pause99_share_perms_makeco_m" => \@mods, size => (@mods > 18 ? 15 : scalar @mods), multiple => "multiple" %> +% } else { +--NONE-- +% } + + + + 3.1 Make somebody else co-maintainer +
+ + 3.2 Remove a co-maintainer
4. You are co-maintainer
+% if (my @mods = @{$pause->{remove_comaintainer} || []}) { +<%= select_field "pause99_share_perms_remome_m" => \@mods, size => (@mods > 18 ? 15 : scalar @mods), multiple => "multiple" %> +% } else { +--NONE-- +% } + + + 4.1 Give up co-maintainership status +
+% } else { +%= include "user/perms/_share_$subaction"; +% } diff --git a/lib/pause_2025/templates/user/reindex.html.ep b/lib/pause_2025/templates/user/reindex.html.ep new file mode 100644 index 000000000..be2863966 --- /dev/null +++ b/lib/pause_2025/templates/user/reindex.html.ep @@ -0,0 +1,58 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; +% my $files = $pause->{files} || {}; + + +

Indexing normally happens only once, shortly after the upload takes place. Sometimes it is necessary to reindex a file. The reason is typically one of the following:

+
    + +
  • A file that contained a current version of a module got deleted, now an older file should be considered current.
    • + +
  • The perms table got altered, now a file should be visited again to overrule the previous indexing decision.
    • + +
  • At the time of uploading PAUSE had a bug and made a wrong indexing decision.
    • + +
+ +

With this form you can tell the indexer to index selected files again. As it is done by a cron job, it may take up to an hour until the indexer actually executes the command. If this doesn't repair the index, please email me.

+ +% if (%$files) { +% if ($pause->{mailbody}) { +
<%= $pause->{mailbody} %>
+% } + +

Files in directory authors/id/<%= $pause->{userhome} %>

+ +
+ + + + + + + + + + +% for my $file (sort keys %$files) { + + + + +% } + +
File
<%= check_box "pause99_reindex_FILE" => $file %><%= $file %>
+

+
+% content_for javascript => begin +%= javascript "/list.min.js" +%= javascript begin +var List = new List('files', { + valueNames: ['file'] +}); +% end +% end + +% } else { +No files found in authors/id/<%= $pause->{userhome} %> +% } diff --git a/lib/pause_2025/templates/user/reset_version.html.ep b/lib/pause_2025/templates/user/reset_version.html.ep new file mode 100644 index 000000000..0c649fe5c --- /dev/null +++ b/lib/pause_2025/templates/user/reset_version.html.ep @@ -0,0 +1,71 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + + +

Note: resetting versions is a major inconvenience for +module users. This page will probably be withdrawn from PAUSE if +the perl community does not want to allow decreasing version numbers +on the CPAN. For now: use with care. Thanks.

+ +

Below you see the packages and version numbers that +the indexer considers the current and highest version number that +it has seen so far. By selecting an item in the list and clicking +Forget, this value is set to undef. This opens the +way for a Force Reindexing run in which the version of the +package in the reindexed distribution can become the current.

+ +

Did I say, this operation should not be done lightly? Because +users of the module out there may still have that higher version +installed and so will not notice the newer but lower-numbered +release. Let me repeat: please make responsible use of this +page.

+ +

Q: So why is this page up at all?

+ +

A: Combine a multi-module-distro with a small mistake in an +older release or a bug in the PAUSE indexer. In such a case you +will be happy to use this page and nobody else will ever notice +there was a problem.

+% if ($pause->{mailbody}) { +
<%= $pause->{mailbody} %>
+% } +% if (%{$pause->{packages} || {}}) { +

<%= scalar keys %{$pause->{packages}} %> <%= keys %{$pause->{packages}} == 1 ? "package" : "packages" %> associated with <%= $pause->{User}{userid} %>

+ +
+ + + + + + + + + + + + +% for my $package (sort keys %{$pause->{packages}}) { + + + + + + +% } + +
PackageVersionDist
<%= check_box pause99_reset_version_PKG => $package %><%= $package %><%= $pause->{packages}{$package}{version} %><%= $pause->{packages}{$package}{dist} %>
+

+
+% content_for javascript => begin +%= javascript "/list.min.js" +%= javascript begin +var List = new List('packages', { + valueNames: ['package', 'version', 'dist'] +}); +% end +% end + +% } else { +

No packages associated with <%= $pause->{User}{userid} %>

+% } diff --git a/lib/pause_2025/templates/user/show_ml_repr.html.ep b/lib/pause_2025/templates/user/show_ml_repr.html.ep new file mode 100644 index 000000000..aad827860 --- /dev/null +++ b/lib/pause_2025/templates/user/show_ml_repr.html.ep @@ -0,0 +1,2 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; diff --git a/lib/pause_2025/templates/user/tail_logfile.html.ep b/lib/pause_2025/templates/user/tail_logfile.html.ep new file mode 100644 index 000000000..b7a469320 --- /dev/null +++ b/lib/pause_2025/templates/user/tail_logfile.html.ep @@ -0,0 +1,21 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + +
+<%= select_field pause99_tail_logfile_1 => [qw/2000 5000 10000 20000 40000/]; =%> + + + + + % for (split /\n/, $pause->{tail}) { + + % } + +
<%= $_ %>
+
+% content_for javascript => begin +%= javascript "/list.min.js" +%= javascript begin +var logList = new List('logs', {valueNames: ['log']}); +% end +% end diff --git a/lib/pause_2025/templates/user/uri/_continued.html.ep b/lib/pause_2025/templates/user/uri/_continued.html.ep new file mode 100644 index 000000000..6a797af33 --- /dev/null +++ b/lib/pause_2025/templates/user/uri/_continued.html.ep @@ -0,0 +1,64 @@ +% my $pause = stash(".pause") || {}; + +
+ + +% if ($pause->{invalid_uri}) { +% } else { + +

Submitting query

+ +% if ($pause->{query_succeeded}) { + +

Query succeeded. Thank you for your contribution

+ +

As it is done by a separate process, it may take a few minutes to +complete the upload. The processing of your file is going on while you +read this. There's no need for you to retry. The form below is only +here in case you want to upload further files.

+ +

Please tidy up your homedir: CPAN is getting larger every day which +is nice but usually there is no need to keep old an outdated version +of a module on several hundred mirrors. Please consider ">removing old versions of +your module from PAUSE and CPAN. If you are worried that someone might +need an old version, it can always be found on the backpan +

+ +

Debugging: your submission should show up soon at <%= $pause->{usrdir} %>. If something's wrong, please +check the logfile of the daemon: see the tail of it with <%= $pause->{tailurl} %>. If you already know what's going wrong, you +may wish to visit the ">repair +tool for pending uploads.

+ +% } else { + +

Could not enter the URL into the database. +Reason:

<%= $pause->{errmsg} %>

+ +% if ($pause->{duplicate}) { +

This indicates that you probably tried to upload a file that is +already in the database. You will most probably have to rename your +file and try again, because PAUSE doesn't let you upload a file +twice.

+ +

This seems to be the record causing the conflict:
+ +% if (my $rec = $pause->{rec}) { +% for my $k (sort keys %$rec) { + +% } +% } +
<%= $k %><%= $rec->{$k} || b(" ") %>
+

+ +% } +% } +% } + + +
+ +
diff --git a/lib/pause_2025/templates/user/uri/add.html.ep b/lib/pause_2025/templates/user/uri/add.html.ep new file mode 100644 index 000000000..6ebadc673 --- /dev/null +++ b/lib/pause_2025/templates/user/uri/add.html.ep @@ -0,0 +1,133 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + + +<%# just for compatibility; will be removed eventually =%> + +

Add a file for <%= $pause->{HiddenUser}{userid} %>

+ +% if (my $to = $pause->{successfully_copied_to}) { +

File successfully copied to '<%= $to %>'

+% } + +% if (my $renamed = $pause->{upload_is_renamed}) { + +

Your filename has been altered as it contained characters besides +the class [A-Za-z0-9_\\-\\.\\@\\+]. DEBUG: your filename[<%= $renamed->{from} %>] corrected +filename[<%= $renamed->{to} %>].

+ +% } + +% if (! $pause->{uploaded_uri} ) { +
+% } else { + +%= include "user/uri/_continued"; + +% } + + + +

This form enables you to enter one file at a time +into CPAN in one of these ways:

+ +% if ($pause->{tryupload}) { + +

HTTP Upload: As an +HTTP upload: enter the filename in the lower text field. +Hint: If you encounter problems processing this form, +it may be due to the fact that your browser can't handle +multipart/form-data forms that support file +upload. In such a case, please retry to access this 0) %>">file-upload-disabled form.

+ +% } else { + +

HTTP Upload: As +you do not seem to want HTTP upload enabled, we do +not offer it. If this is not what you want, try to + 1) %>">explicitly enable HTTP upload.

+ +% } + +

GET URL: PAUSE fetches any http or ftp +URL that can be handled by LWP (Note: https is currently not +supported): use the text field (please specify the complete +URL).

+ +
Please, make sure your filename +contains a version number. For security reasons you will never +be able to upload a file with the same name again (not even +after deleting it). Thank you.
+ +

There is no need to upload README files separately. The +upload server will unwrap your files (.tar.gz or .zip files +only) within a few hours after uploading and will put the +topmost README file as, say, Foo-Bar-3.14.readme into your +directory. Hint: if you're looking for an even more +convenient way to upload files than this form, you can try the +cpan-upload script. +

+ +

Target Directory

If you want to load the +file into a directory below your CPAN directory, +please specify the directory name here. Any number of +subdirectory levels is allowed, they all will be +created on the fly if they don't exist yet. Only sane +directory names are allowed and the number of +characters for the whole path is limited.

+NOTE: To upload a Perl6 distribution a target +directory whose top level subdirectory is "Perl6" must +be specified. In addition, a Perl6 distribution must +contain a META6.json. Pause will only consider it a +Perl6 dist if these two conditions are satisfied. +

+ +
+

+<%= text_field "pause99_add_uri_subdirtext", + size => 32, + maxlength => 128, +%> + +% if (@{$pause->{subdirs} || []}) { +
+<%= select_field "pause99_add_uri_subdirscrl" => $pause->{subdirs}, + size => (@{$pause->{subdirs}} > 18 ? 15 : scalar @{$pause->{subdirs}}), +%> +% } +

+
+ +

Upload Material

+ +% if ($pause->{tryupload}) { +
+ +

If your browser can handle +file upload, enter the filename here and I'll transfer it +to your homedirectory:
+ +

<%= file_field "pause99_add_uri_httpupload", + size => 50, +%>
+

+ +
+% } + +
+

If you want me to fetch a file from an URL, enter the full URL here.
+ +

<%= text_field "pause99_add_uri_uri", + size => 64, + maxlength => 128, +%>
+

+
From f2495b19a602ed54dbeedc4c64a97298cb68f943 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 19 Apr 2025 17:08:22 +0900 Subject: [PATCH 02/51] Rename PAUSE::Web under lib/pause_2025 as PAUSE::Web2025 --- lib/pause_2025/PAUSE/{Web.pm => Web2025.pm} | 32 +++++++++---------- .../PAUSE/{Web => Web2025}/App/Disabled.pm | 2 +- .../PAUSE/{Web => Web2025}/App/Index.pm | 2 +- .../PAUSE/{Web => Web2025}/Config.pm | 2 +- .../PAUSE/{Web => Web2025}/Context.pm | 12 +++---- .../{Web => Web2025}/Controller/Admin.pm | 2 +- .../Controller/Admin/ManageId.pm | 2 +- .../{Web => Web2025}/Controller/Admin/User.pm | 8 ++--- .../{Web => Web2025}/Controller/Mlrepr.pm | 2 +- .../{Web => Web2025}/Controller/Public.pm | 16 +++++----- .../Controller/Public/RequestId.pm | 18 +++++------ .../PAUSE/{Web => Web2025}/Controller/Root.pm | 2 +- .../PAUSE/{Web => Web2025}/Controller/User.pm | 18 +++++------ .../{Web => Web2025}/Controller/User/Cred.pm | 8 ++--- .../Controller/User/Distperms.pm | 18 +++++------ .../{Web => Web2025}/Controller/User/Files.pm | 2 +- .../{Web => Web2025}/Controller/User/Perms.pm | 18 +++++------ .../{Web => Web2025}/Controller/User/Uri.pm | 16 +++++----- .../PAUSE/{Web => Web2025}/Exception.pm | 2 +- .../{Web => Web2025}/Middleware/Auth/Basic.pm | 2 +- .../Plugin/ConfigPerRequest.pm | 16 +++++----- .../PAUSE/{Web => Web2025}/Plugin/Delegate.pm | 2 +- .../{Web => Web2025}/Plugin/EditUtils.pm | 2 +- .../{Web => Web2025}/Plugin/FixAction.pm | 2 +- .../Plugin/GetActiveUserRecord.pm | 8 ++--- .../{Web => Web2025}/Plugin/GetUserMeta.pm | 2 +- .../{Web => Web2025}/Plugin/IsPauseClosed.pm | 2 +- .../PAUSE/{Web => Web2025}/Plugin/MyURL.pm | 2 +- .../{Web => Web2025}/Plugin/RenderYAML.pm | 2 +- .../{Web => Web2025}/Plugin/ServePauseDoc.pm | 6 ++-- .../{Web => Web2025}/Plugin/SessionCounted.pm | 2 +- .../{Web => Web2025}/Plugin/TextFormat.pm | 2 +- .../Plugin/UserRegistration.pm | 4 +-- .../{Web => Web2025}/Plugin/WrapAction.pm | 4 +-- .../PAUSE/{Web => Web2025}/Util/Encode.pm | 2 +- .../{Web => Web2025}/Util/RewriteXHTML.pm | 6 ++-- 36 files changed, 124 insertions(+), 124 deletions(-) rename lib/pause_2025/PAUSE/{Web.pm => Web2025.pm} (74%) rename lib/pause_2025/PAUSE/{Web => Web2025}/App/Disabled.pm (93%) rename lib/pause_2025/PAUSE/{Web => Web2025}/App/Index.pm (97%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Config.pm (99%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Context.pm (94%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Controller/Admin.pm (99%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Controller/Admin/ManageId.pm (98%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Controller/Admin/User.pm (98%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Controller/Mlrepr.pm (97%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Controller/Public.pm (94%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Controller/Public/RequestId.pm (93%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Controller/Root.pm (96%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Controller/User.pm (96%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Controller/User/Cred.pm (97%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Controller/User/Distperms.pm (97%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Controller/User/Files.pm (99%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Controller/User/Perms.pm (98%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Controller/User/Uri.pm (96%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Exception.pm (80%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Middleware/Auth/Basic.pm (99%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Plugin/ConfigPerRequest.pm (94%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Plugin/Delegate.pm (91%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Plugin/EditUtils.pm (94%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Plugin/FixAction.pm (97%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Plugin/GetActiveUserRecord.pm (94%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Plugin/GetUserMeta.pm (99%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Plugin/IsPauseClosed.pm (95%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Plugin/MyURL.pm (95%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Plugin/RenderYAML.pm (89%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Plugin/ServePauseDoc.pm (88%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Plugin/SessionCounted.pm (98%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Plugin/TextFormat.pm (88%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Plugin/UserRegistration.pm (98%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Plugin/WrapAction.pm (93%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Util/Encode.pm (97%) rename lib/pause_2025/PAUSE/{Web => Web2025}/Util/RewriteXHTML.pm (90%) diff --git a/lib/pause_2025/PAUSE/Web.pm b/lib/pause_2025/PAUSE/Web2025.pm similarity index 74% rename from lib/pause_2025/PAUSE/Web.pm rename to lib/pause_2025/PAUSE/Web2025.pm index f2ba1ae2f..bc9337e52 100644 --- a/lib/pause_2025/PAUSE/Web.pm +++ b/lib/pause_2025/PAUSE/Web2025.pm @@ -1,10 +1,10 @@ -package PAUSE::Web; +package PAUSE::Web2025; use Mojo::Base "Mojolicious"; use MojoX::Log::Dispatch::Simple; use Digest::SHA1 qw/sha1_hex/; -has pause => sub { Carp::confess "requires PAUSE::Web::Context" }; +has pause => sub { Carp::confess "requires PAUSE::Web2025::Context" }; sub startup { my $app = shift; @@ -33,20 +33,20 @@ sub startup { # Load plugins to modify path/set stash values/provide helper methods $app->plugin("WithCSRFProtection"); - $app->plugin("PAUSE::Web::Plugin::ConfigPerRequest"); - $app->plugin("PAUSE::Web::Plugin::IsPauseClosed"); - $app->plugin("PAUSE::Web::Plugin::GetActiveUserRecord"); - $app->plugin("PAUSE::Web::Plugin::GetUserMeta"); - $app->plugin("PAUSE::Web::Plugin::ServePauseDoc"); - $app->plugin("PAUSE::Web::Plugin::FixAction"); - $app->plugin("PAUSE::Web::Plugin::WrapAction"); - $app->plugin("PAUSE::Web::Plugin::EditUtils"); - $app->plugin("PAUSE::Web::Plugin::Delegate"); - $app->plugin("PAUSE::Web::Plugin::SessionCounted"); - $app->plugin("PAUSE::Web::Plugin::MyURL"); - $app->plugin("PAUSE::Web::Plugin::RenderYAML"); - $app->plugin("PAUSE::Web::Plugin::TextFormat"); - $app->plugin("PAUSE::Web::Plugin::UserRegistration"); + $app->plugin("PAUSE::Web2025::Plugin::ConfigPerRequest"); + $app->plugin("PAUSE::Web2025::Plugin::IsPauseClosed"); + $app->plugin("PAUSE::Web2025::Plugin::GetActiveUserRecord"); + $app->plugin("PAUSE::Web2025::Plugin::GetUserMeta"); + $app->plugin("PAUSE::Web2025::Plugin::ServePauseDoc"); + $app->plugin("PAUSE::Web2025::Plugin::FixAction"); + $app->plugin("PAUSE::Web2025::Plugin::WrapAction"); + $app->plugin("PAUSE::Web2025::Plugin::EditUtils"); + $app->plugin("PAUSE::Web2025::Plugin::Delegate"); + $app->plugin("PAUSE::Web2025::Plugin::SessionCounted"); + $app->plugin("PAUSE::Web2025::Plugin::MyURL"); + $app->plugin("PAUSE::Web2025::Plugin::RenderYAML"); + $app->plugin("PAUSE::Web2025::Plugin::TextFormat"); + $app->plugin("PAUSE::Web2025::Plugin::UserRegistration"); # Check HTTP headers and set stash my $r = $app->routes->under("/")->to("root#check"); diff --git a/lib/pause_2025/PAUSE/Web/App/Disabled.pm b/lib/pause_2025/PAUSE/Web2025/App/Disabled.pm similarity index 93% rename from lib/pause_2025/PAUSE/Web/App/Disabled.pm rename to lib/pause_2025/PAUSE/Web2025/App/Disabled.pm index ef38fd5cc..d91e37eb5 100644 --- a/lib/pause_2025/PAUSE/Web/App/Disabled.pm +++ b/lib/pause_2025/PAUSE/Web2025/App/Disabled.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::App::Disabled; +package PAUSE::Web2025::App::Disabled; use Mojo::Base -base; use Plack::Request; diff --git a/lib/pause_2025/PAUSE/Web/App/Index.pm b/lib/pause_2025/PAUSE/Web2025/App/Index.pm similarity index 97% rename from lib/pause_2025/PAUSE/Web/App/Index.pm rename to lib/pause_2025/PAUSE/Web2025/App/Index.pm index b56c65318..2d158ee67 100644 --- a/lib/pause_2025/PAUSE/Web/App/Index.pm +++ b/lib/pause_2025/PAUSE/Web2025/App/Index.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::App::Index; +package PAUSE::Web2025::App::Index; use Mojo::Base -base; use Plack::Request; diff --git a/lib/pause_2025/PAUSE/Web/Config.pm b/lib/pause_2025/PAUSE/Web2025/Config.pm similarity index 99% rename from lib/pause_2025/PAUSE/Web/Config.pm rename to lib/pause_2025/PAUSE/Web2025/Config.pm index 04d4e1230..19fb6e4d4 100644 --- a/lib/pause_2025/PAUSE/Web/Config.pm +++ b/lib/pause_2025/PAUSE/Web2025/Config.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Config; +package PAUSE::Web2025::Config; use Mojo::Base -base; use PAUSE; diff --git a/lib/pause_2025/PAUSE/Web/Context.pm b/lib/pause_2025/PAUSE/Web2025/Context.pm similarity index 94% rename from lib/pause_2025/PAUSE/Web/Context.pm rename to lib/pause_2025/PAUSE/Web2025/Context.pm index c642afe69..2bcf547be 100644 --- a/lib/pause_2025/PAUSE/Web/Context.pm +++ b/lib/pause_2025/PAUSE/Web2025/Context.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Context; +package PAUSE::Web2025::Context; use Mojo::Base -base; use Mojo::ByteStream; @@ -8,13 +8,13 @@ use Sys::Hostname (); use Email::Sender::Simple; use Email::MIME; use Data::Dumper; -use PAUSE::Web::Config; -use PAUSE::Web::Exception; +use PAUSE::Web2025::Config; +use PAUSE::Web2025::Exception; our $VERSION = "1072"; has root => sub { Carp::confess "requires root" }; -has config => sub { PAUSE::Web::Config->new }; +has config => sub { PAUSE::Web2025::Config->new }; has logger => sub { Log::Dispatch::Config->instance }; has mailer => sub { Email::Sender::Simple->new }; @@ -97,7 +97,7 @@ sub database_alert { $self->send_mail($header, $mess); open my $fh, ">", $tsf or warn "Could not open $tsf: $!"; } - die PAUSE::Web::Exception->new(ERROR => <<"ERROR_END"); + die PAUSE::Web2025::Exception->new(ERROR => <<"ERROR_END"); Sorry, the PAUSE Database currently seems unavailable.
Administration has been notified.
Please try again later. @@ -193,7 +193,7 @@ sub send_mail { if (my $error = $@) { if ($error->isa('Email::Sender::Failure')) { warn "Sendmail error: $error"; - die PAUSE::Web::Exception->new(ERROR => Mojo::ByteStream->new(<<"ERROR_END")); + die PAUSE::Web2025::Exception->new(ERROR => Mojo::ByteStream->new(<<"ERROR_END")); Sorry, the PAUSE failed to send an email.
Administration has been notified. ERROR_END diff --git a/lib/pause_2025/PAUSE/Web/Controller/Admin.pm b/lib/pause_2025/PAUSE/Web2025/Controller/Admin.pm similarity index 99% rename from lib/pause_2025/PAUSE/Web/Controller/Admin.pm rename to lib/pause_2025/PAUSE/Web2025/Controller/Admin.pm index ed601df7b..56c89ba6f 100644 --- a/lib/pause_2025/PAUSE/Web/Controller/Admin.pm +++ b/lib/pause_2025/PAUSE/Web2025/Controller/Admin.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Controller::Admin; +package PAUSE::Web2025::Controller::Admin; use Mojo::Base "Mojolicious::Controller"; diff --git a/lib/pause_2025/PAUSE/Web/Controller/Admin/ManageId.pm b/lib/pause_2025/PAUSE/Web2025/Controller/Admin/ManageId.pm similarity index 98% rename from lib/pause_2025/PAUSE/Web/Controller/Admin/ManageId.pm rename to lib/pause_2025/PAUSE/Web2025/Controller/Admin/ManageId.pm index 6fd2f120d..d75576cab 100644 --- a/lib/pause_2025/PAUSE/Web/Controller/Admin/ManageId.pm +++ b/lib/pause_2025/PAUSE/Web2025/Controller/Admin/ManageId.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Controller::Admin::ManageId; +package PAUSE::Web2025::Controller::Admin::ManageId; use Mojo::Base "Mojolicious::Controller"; use Storable; diff --git a/lib/pause_2025/PAUSE/Web/Controller/Admin/User.pm b/lib/pause_2025/PAUSE/Web2025/Controller/Admin/User.pm similarity index 98% rename from lib/pause_2025/PAUSE/Web/Controller/Admin/User.pm rename to lib/pause_2025/PAUSE/Web2025/Controller/Admin/User.pm index 8f542932a..aa9869968 100644 --- a/lib/pause_2025/PAUSE/Web/Controller/Admin/User.pm +++ b/lib/pause_2025/PAUSE/Web2025/Controller/Admin/User.pm @@ -1,7 +1,7 @@ -package PAUSE::Web::Controller::Admin::User; +package PAUSE::Web2025::Controller::Admin::User; use Mojo::Base "Mojolicious::Controller"; -use PAUSE::Web::Util::Encode; +use PAUSE::Web2025::Util::Encode; use Text::Soundex; use Text::Metaphone; use Text::Format; @@ -40,7 +40,7 @@ sub add { my $doit = 0; my $fullname_raw = $req->param('pause99_add_user_fullname') // ''; my($fullname); - $fullname = PAUSE::Web::Util::Encode::any2utf8($fullname_raw); + $fullname = PAUSE::Web2025::Util::Encode::any2utf8($fullname_raw); warn "fullname[$fullname]fullname_raw[$fullname_raw]"; if ($fullname ne $fullname_raw) { $req->param("pause99_add_user_fullname" => $fullname); @@ -263,7 +263,7 @@ sub add_user_doit { my @qbind2 = ($maillistid, $maillistname, $subscribe, $changed, $pause->{User}{userid}, $email); unless ($dbh->do($query,undef,@qbind2)) { - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => [qq{Query[$query]with qbind2[@qbind2] failed. Reason:}, $DBI::errstr]); } diff --git a/lib/pause_2025/PAUSE/Web/Controller/Mlrepr.pm b/lib/pause_2025/PAUSE/Web2025/Controller/Mlrepr.pm similarity index 97% rename from lib/pause_2025/PAUSE/Web/Controller/Mlrepr.pm rename to lib/pause_2025/PAUSE/Web2025/Controller/Mlrepr.pm index 3d71bb403..130ef6f36 100644 --- a/lib/pause_2025/PAUSE/Web/Controller/Mlrepr.pm +++ b/lib/pause_2025/PAUSE/Web2025/Controller/Mlrepr.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Controller::Mlrepr; +package PAUSE::Web2025::Controller::Mlrepr; use Mojo::Base "Mojolicious::Controller"; diff --git a/lib/pause_2025/PAUSE/Web/Controller/Public.pm b/lib/pause_2025/PAUSE/Web2025/Controller/Public.pm similarity index 94% rename from lib/pause_2025/PAUSE/Web/Controller/Public.pm rename to lib/pause_2025/PAUSE/Web2025/Controller/Public.pm index 46ae90bb2..0189c4cd8 100644 --- a/lib/pause_2025/PAUSE/Web/Controller/Public.pm +++ b/lib/pause_2025/PAUSE/Web2025/Controller/Public.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Controller::Public; +package PAUSE::Web2025::Controller::Public; use Mojo::Base "Mojolicious::Controller"; use Time::Duration; @@ -26,10 +26,10 @@ sub mailpw { $param = uc($param); unless ($param =~ /^[A-Z\-]+$/) { if ($param =~ /@/) { - die PAUSE::Web::Exception->new(ERROR => + die PAUSE::Web2025::Exception->new(ERROR => qq{Please supply a userid, not an email address.}); } - die PAUSE::Web::Exception->new(ERROR => + die PAUSE::Web2025::Exception->new(ERROR => qq{A userid of $param is not allowed, please retry with a valid userid. Nothing done.}); # FIXME } $pause->{mailpw_userid} = $param; @@ -52,7 +52,7 @@ sub mailpw { }; if ($@) { # FIXME - die PAUSE::Web::Exception->new(ERROR => + die PAUSE::Web2025::Exception->new(ERROR => qq{Cannot find a userid of $param, please retry with a valid @@ -64,13 +64,13 @@ sub mailpw { VALUES (?, ?, 1, ?)}; $authen_dbh->do($sql,{},$u->{userid},$u->{email},time) - or die PAUSE::Web::Exception->new(ERROR => + or die PAUSE::Web2025::Exception->new(ERROR => qq{The userid of $param is too old for this interface. Please get in touch with administration.}); # FIXME $rec->{secretemail} = $u->{email}; } else { - die PAUSE::Web::Exception->new(ERROR => + die PAUSE::Web2025::Exception->new(ERROR => qq{A userid of $param is not known, please retry with a valid userid.}); # FIXME } @@ -109,7 +109,7 @@ sub mailpw { } elsif ($authen_dbh->errstr =~ /Duplicate entry/) { my $duration; $duration = Time::Duration::duration($PAUSE::Config->{ABRA_EXPIRATION}); - die PAUSE::Web::Exception->new + die PAUSE::Web2025::Exception->new ( ERROR => qq{A token for $param that allows changing of the password has been requested recently @@ -117,7 +117,7 @@ sub mailpw { done.} ); } else { - die PAUSE::Web::Exception->new(ERROR => $authen_dbh->errstr); + die PAUSE::Web2025::Exception->new(ERROR => $authen_dbh->errstr); } # between Apache::URI and URI::URL diff --git a/lib/pause_2025/PAUSE/Web/Controller/Public/RequestId.pm b/lib/pause_2025/PAUSE/Web2025/Controller/Public/RequestId.pm similarity index 93% rename from lib/pause_2025/PAUSE/Web/Controller/Public/RequestId.pm rename to lib/pause_2025/PAUSE/Web2025/Controller/Public/RequestId.pm index 5ea014ceb..d47910bb8 100644 --- a/lib/pause_2025/PAUSE/Web/Controller/Public/RequestId.pm +++ b/lib/pause_2025/PAUSE/Web2025/Controller/Public/RequestId.pm @@ -1,7 +1,7 @@ -package PAUSE::Web::Controller::Public::RequestId; +package PAUSE::Web2025::Controller::Public::RequestId; use Mojo::Base "Mojolicious::Controller"; -use PAUSE::Web::Util::Encode; +use PAUSE::Web2025::Util::Encode; use Email::Address; sub request { @@ -26,7 +26,7 @@ sub request { } my $fullname = $req->param('pause99_request_id_fullname') || ""; - my $ufullname = PAUSE::Web::Util::Encode::any2utf8($fullname); + my $ufullname = PAUSE::Web2025::Util::Encode::any2utf8($fullname); if ($ufullname ne $fullname) { $req->param("pause99_request_id_fullname" => $ufullname); $fullname = $ufullname; @@ -36,7 +36,7 @@ sub request { my $userid = $req->param('pause99_request_id_userid') || ""; my $rationale = $req->param("pause99_request_id_rationale") || ""; my $token = $req->param("g-recaptcha-response") || ""; - my $urat = PAUSE::Web::Util::Encode::any2utf8($rationale); + my $urat = PAUSE::Web2025::Util::Encode::any2utf8($rationale); if ($urat ne $rationale) { $req->param("pause99_request_id_rationale" => $urat); $rationale = $urat; @@ -132,7 +132,7 @@ sub request { return $c->_directly_add_user($userid, $fullname); } elsif ( defined $valid && ! $valid ) { - die PAUSE::Web::Exception->new(ERROR => "recaptcha failed validation: $err\n"); + die PAUSE::Web2025::Exception->new(ERROR => "recaptcha failed validation: $err\n"); } # else recapture couldn't complete so continue with normal # ID request moderation @@ -167,16 +167,16 @@ sub request { my $message = "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . Data::Dumper->new([$session->{APPLY}],[qw(APPLY)])->Indent(1)->Useqq(1)->Dump; $c->app->pause->log({level => 'debug', message => $message }); if (lc($fullname) eq lc($userid)) { - die PAUSE::Web::Exception->new(ERROR => "fullname looks like spam"); + die PAUSE::Web2025::Exception->new(ERROR => "fullname looks like spam"); } if (my @x = $rationale =~ /(\.info)/g) { - die PAUSE::Web::Exception->new(ERROR => "rationale looks like spam") if @x >= 5; + die PAUSE::Web2025::Exception->new(ERROR => "rationale looks like spam") if @x >= 5; } if (my @x = $rationale =~ m|(http://)|g) { - die PAUSE::Web::Exception->new(ERROR => "rationale looks like spam") if @x >= 5; + die PAUSE::Web2025::Exception->new(ERROR => "rationale looks like spam") if @x >= 5; } if ($rationale =~ /interesting/i && $homepage =~ m|http://[^/]+\.cn/.+\.htm$|) { - die PAUSE::Web::Exception->new(ERROR => "rationale looks like spam"); + die PAUSE::Web2025::Exception->new(ERROR => "rationale looks like spam"); } $pause->{fullname} = $fullname; diff --git a/lib/pause_2025/PAUSE/Web/Controller/Root.pm b/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm similarity index 96% rename from lib/pause_2025/PAUSE/Web/Controller/Root.pm rename to lib/pause_2025/PAUSE/Web2025/Controller/Root.pm index c2e2397fc..76edba46b 100644 --- a/lib/pause_2025/PAUSE/Web/Controller/Root.pm +++ b/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Controller::Root; +package PAUSE::Web2025::Controller::Root; use Mojo::Base "Mojolicious::Controller"; diff --git a/lib/pause_2025/PAUSE/Web/Controller/User.pm b/lib/pause_2025/PAUSE/Web2025/Controller/User.pm similarity index 96% rename from lib/pause_2025/PAUSE/Web/Controller/User.pm rename to lib/pause_2025/PAUSE/Web2025/Controller/User.pm index d15ffede7..cbabf1fe8 100644 --- a/lib/pause_2025/PAUSE/Web/Controller/User.pm +++ b/lib/pause_2025/PAUSE/Web2025/Controller/User.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Controller::User; +package PAUSE::Web2025::Controller::User; use Mojo::Base "Mojolicious::Controller"; use File::pushd; @@ -322,7 +322,7 @@ sub change_passwd { my $req = $c->req; my $u = eval { $c->active_user_record }; - die PAUSE::Web::Exception->new(ERROR => "User not found", HTTP_STATUS => 401) if $@; + die PAUSE::Web2025::Exception->new(ERROR => "User not found", HTTP_STATUS => 401) if $@; if (uc $req->method eq 'POST' and $req->param("pause99_change_passwd_sub")) { if (my $pw1 = $req->param("pause99_change_passwd_pw1")) { @@ -341,7 +341,7 @@ sub change_passwd { my $rc = $dbh->do($sql,undef, $pwenc,0,time,$pause->{User}{userid},$u->{userid}); warn "rc[$rc]"; - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => sprintf qq[Could not set password: '%s'], $dbh->errstr ) unless $rc; @@ -362,13 +362,13 @@ sub change_passwd { $pause->{User}{userid}, $u->{userid} ); - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => sprintf qq[Could not insert user record: '%s'], $dbh->errstr ) unless $rc; } for my $anon ($pause->{User}, $u) { - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => "Panic: unknown user") unless $anon->{userid}; next if $anon->{fullname}; $mgr->log({level => 'error', message => "Unknown fullname for $anon->{userid}!" }); @@ -383,21 +383,21 @@ sub change_passwd { # Remove used token $sql = qq{DELETE FROM abrakadabra WHERE user = ?}; $rc = $dbh->do($sql, undef, $u->{userid}); - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => sprintf qq[Could not delete token: '%s'], $dbh->errstr ) unless $rc; $mgr->log({level => 'info', message => "Removed used token for $u->{userid}" }); } else { - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => "The two passwords didn't match."); } } else { - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => "You need to fill in the same password in both fields."); } } else { - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => "Please fill in the form with passwords."); } } diff --git a/lib/pause_2025/PAUSE/Web/Controller/User/Cred.pm b/lib/pause_2025/PAUSE/Web2025/Controller/User/Cred.pm similarity index 97% rename from lib/pause_2025/PAUSE/Web/Controller/User/Cred.pm rename to lib/pause_2025/PAUSE/Web2025/Controller/User/Cred.pm index 680ed8c4c..e34ffbfe0 100644 --- a/lib/pause_2025/PAUSE/Web/Controller/User/Cred.pm +++ b/lib/pause_2025/PAUSE/Web2025/Controller/User/Cred.pm @@ -1,8 +1,8 @@ -package PAUSE::Web::Controller::User::Cred; +package PAUSE::Web2025::Controller::User::Cred; use Mojo::Base "Mojolicious::Controller"; use Email::Address; -use PAUSE::Web::Util::Encode; +use PAUSE::Web2025::Util::Encode; use Text::Unidecode; sub edit { @@ -63,7 +63,7 @@ sub edit { # set asciiname on our own if they don't supply it my $wantfullname = $req->param("pause99_edit_cred_fullname"); if ($wantfullname =~ /[^\040-\177]/) { - $wantfullname = PAUSE::Web::Util::Encode::any2utf8($wantfullname); + $wantfullname = PAUSE::Web2025::Util::Encode::any2utf8($wantfullname); $wantasciiname = Text::Unidecode::unidecode($wantfullname); $req->param("pause99_edit_cred_asciiname", $wantasciiname); } @@ -133,7 +133,7 @@ sub edit { my $s_raw = $req->param($form_field) || ""; # we're in edit_cred my $s; - $s = PAUSE::Web::Util::Encode::any2utf8($s_raw); + $s = PAUSE::Web2025::Util::Encode::any2utf8($s_raw); $s =~ s/^\s+//; $s =~ s/\s+\z//; if ($s ne $s_raw) { diff --git a/lib/pause_2025/PAUSE/Web/Controller/User/Distperms.pm b/lib/pause_2025/PAUSE/Web2025/Controller/User/Distperms.pm similarity index 97% rename from lib/pause_2025/PAUSE/Web/Controller/User/Distperms.pm rename to lib/pause_2025/PAUSE/Web2025/Controller/User/Distperms.pm index fcc96716c..fcca4583c 100644 --- a/lib/pause_2025/PAUSE/Web/Controller/User/Distperms.pm +++ b/lib/pause_2025/PAUSE/Web2025/Controller/User/Distperms.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Controller::User::Distperms; +package PAUSE::Web2025::Controller::User::Distperms; use Mojo::Base "Mojolicious::Controller"; @@ -42,7 +42,7 @@ sub peek { @bind = ($qterm, $qterm); $where = qq{WHERE primeur.userid=? OR perms.userid=? GROUP BY packages.distname}; } else { - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => "Illegal parameter for pause99_peek_dist_perms_by"); } $query .= $where; @@ -115,14 +115,14 @@ sub move_dist_primary { FROM users WHERE userid=?"); $sth1->execute($other_user); - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => "$other_user is not a valid userid.") unless $sth1->rows; local($db->{RaiseError}) = 0; my $sth = $db->prepare("UPDATE primeur SET userid=? WHERE package=?"); my @results; for my $seldist (@seldists) { - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => "You do not seem to be maintainer of $seldist") unless exists $all_dists->{$seldist}; my $mods = $db->selectcol_arrayref( @@ -200,7 +200,7 @@ sub remove_dist_primary { my @results; for my $seldist (@seldists) { - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => "You do not seem to be maintainer of $seldist") unless exists $all_dists->{$seldist}; my $mods = $db->selectcol_arrayref( @@ -271,7 +271,7 @@ sub make_dist_comaint { FROM users WHERE userid=?"); $sth1->execute($other_user); - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => sprintf( "$other_user is not a valid userid.", ) @@ -282,7 +282,7 @@ sub make_dist_comaint { VALUES (?,?,?)"); my @results; for my $seldist (@seldists) { - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => "You do not seem to be maintainer of $seldist") unless exists $all_dists->{$seldist}; my $mods = $db->selectcol_arrayref( @@ -358,7 +358,7 @@ sub remove_dist_comaint { my @results; for my $sel (@sel) { my($seldist,$otheruser) = $sel =~ /^(\S+)\s--\s(\S+)$/; - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => "You do not seem to be owner of $seldist.") unless exists $all_dists->{$seldist}; unless (exists $all_comaints->{$sel}) { @@ -430,7 +430,7 @@ sub giveup_dist_comaint { my @results; for my $seldist (@seldists) { - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => "You do not seem to be co-maintainer of $seldist") unless exists $all_dists->{$seldist}; my $mods = $db->selectcol_arrayref( diff --git a/lib/pause_2025/PAUSE/Web/Controller/User/Files.pm b/lib/pause_2025/PAUSE/Web2025/Controller/User/Files.pm similarity index 99% rename from lib/pause_2025/PAUSE/Web/Controller/User/Files.pm rename to lib/pause_2025/PAUSE/Web2025/Controller/User/Files.pm index 822fc3790..c3ec9d771 100644 --- a/lib/pause_2025/PAUSE/Web/Controller/User/Files.pm +++ b/lib/pause_2025/PAUSE/Web2025/Controller/User/Files.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Controller::User::Files; +package PAUSE::Web2025::Controller::User::Files; use Mojo::Base "Mojolicious::Controller"; use HTTP::Date (); diff --git a/lib/pause_2025/PAUSE/Web/Controller/User/Perms.pm b/lib/pause_2025/PAUSE/Web2025/Controller/User/Perms.pm similarity index 98% rename from lib/pause_2025/PAUSE/Web/Controller/User/Perms.pm rename to lib/pause_2025/PAUSE/Web2025/Controller/User/Perms.pm index 43972fa6d..13e9b118e 100644 --- a/lib/pause_2025/PAUSE/Web/Controller/User/Perms.pm +++ b/lib/pause_2025/PAUSE/Web2025/Controller/User/Perms.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Controller::User::Perms; +package PAUSE::Web2025::Controller::User::Perms; use Mojo::Base "Mojolicious::Controller"; @@ -61,7 +61,7 @@ sub peek { } elsif ($by eq "a") { $where = qq{WHERE $fmap->{userid}=?}; } else { - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => "Illegal parameter for pause99_peek_perms_by"); } $query .= $where; @@ -218,14 +218,14 @@ sub _share_movepr { FROM users WHERE userid=?"); $sth1->execute($other_user); - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => "$other_user is not a valid userid.") unless $sth1->rows; local($db->{RaiseError}) = 0; my $sth = $db->prepare("UPDATE primeur SET userid=? WHERE package=?"); my @results; for my $selmod (@selmods) { - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => "You do not seem to be maintainer of $selmod") unless exists $all_mods->{$selmod}; my $ret = $sth->execute($other_user,$selmod); @@ -300,7 +300,7 @@ sub _share_remopr { my @results; for my $selmod (@selmods) { - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => "You do not seem to be maintainer of $selmod") unless exists $all_mods->{$selmod}; my $ret = $sth->execute('ADOPTME',$u->{userid},$selmod); @@ -369,7 +369,7 @@ sub _share_makeco { FROM users WHERE userid=?"); $sth1->execute($other_user); - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => sprintf( "$other_user is not a valid userid.", ) @@ -381,7 +381,7 @@ sub _share_makeco { my @results; for my $selmod (@selmods) { - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => "You do not seem to be maintainer of $selmod") unless exists $all_mods->{$selmod}; my $ret = $sth->execute($selmod,lc $selmod,$other_user); @@ -453,7 +453,7 @@ sub _share_remocos { my @results; for my $sel (@sel) { my($selmod,$otheruser) = $sel =~ /^(\S+)\s--\s(\S+)$/; - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => "You do not seem to be owner of $selmod.") unless exists $all_mods->{$selmod}; unless (exists $all_comaints->{$sel}) { @@ -522,7 +522,7 @@ sub _share_remome { my @results; for my $selmod (@selmods) { - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => "You do not seem to be co-maintainer of $selmod") unless exists $all_mods->{$selmod}; my $ret = $sth->execute($selmod,$u->{userid}); diff --git a/lib/pause_2025/PAUSE/Web/Controller/User/Uri.pm b/lib/pause_2025/PAUSE/Web2025/Controller/User/Uri.pm similarity index 96% rename from lib/pause_2025/PAUSE/Web/Controller/User/Uri.pm rename to lib/pause_2025/PAUSE/Web2025/Controller/User/Uri.pm index 7f5169e29..48e0e3bed 100644 --- a/lib/pause_2025/PAUSE/Web/Controller/User/Uri.pm +++ b/lib/pause_2025/PAUSE/Web2025/Controller/User/Uri.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Controller::User::Uri; +package PAUSE::Web2025::Controller::User::Uri; use Mojo::Base "Mojolicious::Controller"; use Mojo::ByteStream; @@ -14,7 +14,7 @@ sub add { $PAUSE::Config->{INCOMING_LOC} =~ s|/$||; my $u = $c->active_user_record; - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => "Unidentified error happened, please write to the PAUSE admins at $PAUSE::Config->{ADMIN} and help them identifying what's going on. Thanks!") @@ -75,7 +75,7 @@ sub add { $pause->{successfully_copied_to} = $to; warn "h1[File successfully copied to '$to']filename[$filename]"; } else { - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => "Couldn't copy file '$filename' to '$to': $!"); } @@ -90,12 +90,12 @@ sub add { }; } } else { - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => "uploaded file was zero sized"); } } else { - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => "Could not create an upload object. DEBUG: upl[$upl]"); } @@ -175,7 +175,7 @@ sub add_uri_continue_with_uri { if ($@) { $pause->{invalid_uri} = 1; # FIXME - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => [Mojo::ByteStream->new(qq{ Sorry, $uri could not be recognized as an uri (}), $@, @@ -195,7 +195,7 @@ try again or report errors to new(ERROR => "Files with the name CHECKSUMS cannot be uploaded to CPAN, they are reserved for CPAN's internals."); @@ -224,7 +224,7 @@ try again or report errors to new(ERROR => $error); + die PAUSE::Web2025::Exception->new(ERROR => $error); } else { $pause->{User} = $mgr->fetchrow($sth, "fetchrow_hashref"); } } else { - die PAUSE::Web::Exception->new(ERROR => $dbh->errstr); + die PAUSE::Web2025::Exception->new(ERROR => $dbh->errstr); } $sth->finish; @@ -111,7 +111,7 @@ sub _retrieve_user { $pause->{UserGroups}{$rec->{ugroup}} = undef; } } else { - die PAUSE::Web::Exception->new(ERROR => $dbh2->errstr); + die PAUSE::Web2025::Exception->new(ERROR => $dbh2->errstr); } $sth->finish; @@ -120,7 +120,7 @@ sub _retrieve_user { FROM list2user WHERE userid=?}; $sth = $dbh->prepare($sql); - $sth->execute($user) or die PAUSE::Web::Exception->new(ERROR => $dbh->errstr); + $sth->execute($user) or die PAUSE::Web2025::Exception->new(ERROR => $dbh->errstr); if ($sth->rows > 0) { $pause->{UserGroups}{mlrepr} = undef; # is a virtual group my %mlrepr; @@ -231,7 +231,7 @@ sub _set_allowed_actions { $param = $req->param("ACTION", "change_passwd"); # override } else { - die PAUSE::Web::Exception->new(ERROR => "You tried to authenticate the + die PAUSE::Web2025::Exception->new(ERROR => "You tried to authenticate the parameter ABRA=$param, but the database doesn't know about this token.", HTTP_STATUS => 401); } $allow_action{"mailpw"} = undef; @@ -255,7 +255,7 @@ parameter ABRA=$param, but the database doesn't know about this token.", HTTP_ST $pause->{Action} = $param; } else { warn "$userid tried disallowed action: $param"; - die PAUSE::Web::Exception->new(ERROR => "Forbidden", HTTP_STATUS => 403); + die PAUSE::Web2025::Exception->new(ERROR => "Forbidden", HTTP_STATUS => 403); } } else { # ...they might ask for it in a submit button @@ -319,7 +319,7 @@ parameter ABRA=$param, but the database doesn't know about this token.", HTTP_ST $action = $pause->{Action}; if ($action && !exists $allow_action{$action}) { warn "$userid tried disallowed action: $action"; - die PAUSE::Web::Exception->new(ERROR => "Forbidden", HTTP_STATUS => 403); + die PAUSE::Web2025::Exception->new(ERROR => "Forbidden", HTTP_STATUS => 403); } # warn "action[$action]"; } diff --git a/lib/pause_2025/PAUSE/Web/Plugin/Delegate.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/Delegate.pm similarity index 91% rename from lib/pause_2025/PAUSE/Web/Plugin/Delegate.pm rename to lib/pause_2025/PAUSE/Web2025/Plugin/Delegate.pm index ca38e2241..88c58507c 100644 --- a/lib/pause_2025/PAUSE/Web/Plugin/Delegate.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/Delegate.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Plugin::Delegate; +package PAUSE::Web2025::Plugin::Delegate; # Mojolicious doesn't have this feature with good intention # but we need this anyway diff --git a/lib/pause_2025/PAUSE/Web/Plugin/EditUtils.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/EditUtils.pm similarity index 94% rename from lib/pause_2025/PAUSE/Web/Plugin/EditUtils.pm rename to lib/pause_2025/PAUSE/Web2025/Plugin/EditUtils.pm index 222e3eef3..1b353d671 100644 --- a/lib/pause_2025/PAUSE/Web/Plugin/EditUtils.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/EditUtils.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Plugin::EditUtils; +package PAUSE::Web2025::Plugin::EditUtils; # XXX: Should be removed eventually diff --git a/lib/pause_2025/PAUSE/Web/Plugin/FixAction.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/FixAction.pm similarity index 97% rename from lib/pause_2025/PAUSE/Web/Plugin/FixAction.pm rename to lib/pause_2025/PAUSE/Web2025/Plugin/FixAction.pm index 156dd0dca..a29a7bcc0 100644 --- a/lib/pause_2025/PAUSE/Web/Plugin/FixAction.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/FixAction.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Plugin::FixAction; +package PAUSE::Web2025::Plugin::FixAction; use Mojo::Base "Mojolicious::Plugin"; use HTTP::Status qw/:constants/; diff --git a/lib/pause_2025/PAUSE/Web/Plugin/GetActiveUserRecord.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/GetActiveUserRecord.pm similarity index 94% rename from lib/pause_2025/PAUSE/Web/Plugin/GetActiveUserRecord.pm rename to lib/pause_2025/PAUSE/Web2025/Plugin/GetActiveUserRecord.pm index 73c4a5fab..6134704b8 100644 --- a/lib/pause_2025/PAUSE/Web/Plugin/GetActiveUserRecord.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/GetActiveUserRecord.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Plugin::GetActiveUserRecord; +package PAUSE::Web2025::Plugin::GetActiveUserRecord; use Mojo::Base "Mojolicious::Plugin"; @@ -64,7 +64,7 @@ sub _get { $sth1->rows, $sth1->rows, )); - die PAUSE::Web::Exception->new(ERROR => "Unidentified error happened, please write to the PAUSE admin at $PAUSE::Config->{ADMIN} and help him identifying what's going on. Thanks!"); + die PAUSE::Web2025::Exception->new(ERROR => "Unidentified error happened, please write to the PAUSE admin at $PAUSE::Config->{ADMIN} and help him identifying what's going on. Thanks!"); } my $hiddenuser_h1 = $mgr->fetchrow($sth1, "fetchrow_hashref"); @@ -97,7 +97,7 @@ sub _get { warn "Watch: privilege escalation"; $user = $hiddenuser_h1; # no secrets for a mailinglist } else { - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => sprintf( qq[Action '%s' seems not to be supported @@ -154,7 +154,7 @@ sub _get { my $dbh1 = $mgr->connect; my $sth1 = $dbh1->prepare("SELECT * FROM users WHERE userid=?"); $sth1->execute($pause->{User}{userid}); - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => "Unidentified error happened, please write to the PAUSE admin at $PAUSE::Config->{ADMIN} and help them identify what's going on. Thanks!") diff --git a/lib/pause_2025/PAUSE/Web/Plugin/GetUserMeta.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/GetUserMeta.pm similarity index 99% rename from lib/pause_2025/PAUSE/Web/Plugin/GetUserMeta.pm rename to lib/pause_2025/PAUSE/Web2025/Plugin/GetUserMeta.pm index 14d190f4e..fb57f1532 100644 --- a/lib/pause_2025/PAUSE/Web/Plugin/GetUserMeta.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/GetUserMeta.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Plugin::GetUserMeta; +package PAUSE::Web2025::Plugin::GetUserMeta; use Mojo::Base "Mojolicious::Plugin"; diff --git a/lib/pause_2025/PAUSE/Web/Plugin/IsPauseClosed.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/IsPauseClosed.pm similarity index 95% rename from lib/pause_2025/PAUSE/Web/Plugin/IsPauseClosed.pm rename to lib/pause_2025/PAUSE/Web2025/Plugin/IsPauseClosed.pm index b2ad6bd2d..be936b612 100644 --- a/lib/pause_2025/PAUSE/Web/Plugin/IsPauseClosed.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/IsPauseClosed.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Plugin::IsPauseClosed; +package PAUSE::Web2025::Plugin::IsPauseClosed; use Mojo::Base "Mojolicious::Plugin"; use HTTP::Date (); diff --git a/lib/pause_2025/PAUSE/Web/Plugin/MyURL.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/MyURL.pm similarity index 95% rename from lib/pause_2025/PAUSE/Web/Plugin/MyURL.pm rename to lib/pause_2025/PAUSE/Web2025/Plugin/MyURL.pm index ab0908850..a830837b8 100644 --- a/lib/pause_2025/PAUSE/Web/Plugin/MyURL.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/MyURL.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Plugin::MyURL; +package PAUSE::Web2025::Plugin::MyURL; use Mojo::Base "Mojolicious::Plugin"; use Mojo::URL; diff --git a/lib/pause_2025/PAUSE/Web/Plugin/RenderYAML.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/RenderYAML.pm similarity index 89% rename from lib/pause_2025/PAUSE/Web/Plugin/RenderYAML.pm rename to lib/pause_2025/PAUSE/Web2025/Plugin/RenderYAML.pm index 3d3ad3078..24c134c09 100644 --- a/lib/pause_2025/PAUSE/Web/Plugin/RenderYAML.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/RenderYAML.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Plugin::RenderYAML; +package PAUSE::Web2025::Plugin::RenderYAML; use Mojo::Base "Mojolicious::Plugin"; use YAML::Syck; diff --git a/lib/pause_2025/PAUSE/Web/Plugin/ServePauseDoc.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/ServePauseDoc.pm similarity index 88% rename from lib/pause_2025/PAUSE/Web/Plugin/ServePauseDoc.pm rename to lib/pause_2025/PAUSE/Web2025/Plugin/ServePauseDoc.pm index f3294c4be..dcd1834b3 100644 --- a/lib/pause_2025/PAUSE/Web/Plugin/ServePauseDoc.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/ServePauseDoc.pm @@ -1,7 +1,7 @@ -package PAUSE::Web::Plugin::ServePauseDoc; +package PAUSE::Web2025::Plugin::ServePauseDoc; use Mojo::Base "Mojolicious::Plugin"; -use PAUSE::Web::Util::RewriteXHTML; +use PAUSE::Web2025::Util::RewriteXHTML; use Encode; sub register { @@ -29,7 +29,7 @@ sub _serve_pause_doc { } if ($rewrite and !ref $rewrite) { - $html = PAUSE::Web::Util::RewriteXHTML->rewrite($html); + $html = PAUSE::Web2025::Util::RewriteXHTML->rewrite($html); } else { $html =~ s/^.*?]*>//si; $html =~ s|.*$||si; diff --git a/lib/pause_2025/PAUSE/Web/Plugin/SessionCounted.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/SessionCounted.pm similarity index 98% rename from lib/pause_2025/PAUSE/Web/Plugin/SessionCounted.pm rename to lib/pause_2025/PAUSE/Web2025/Plugin/SessionCounted.pm index 1da5f3f8b..0d914e832 100644 --- a/lib/pause_2025/PAUSE/Web/Plugin/SessionCounted.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/SessionCounted.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Plugin::SessionCounted; +package PAUSE::Web2025::Plugin::SessionCounted; use Mojo::Base "Mojolicious::Plugin"; use Mojo::File; diff --git a/lib/pause_2025/PAUSE/Web/Plugin/TextFormat.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/TextFormat.pm similarity index 88% rename from lib/pause_2025/PAUSE/Web/Plugin/TextFormat.pm rename to lib/pause_2025/PAUSE/Web2025/Plugin/TextFormat.pm index 5f8fd2159..a8ded2b9f 100644 --- a/lib/pause_2025/PAUSE/Web/Plugin/TextFormat.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/TextFormat.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Plugin::TextFormat; +package PAUSE::Web2025::Plugin::TextFormat; use Mojo::Base "Mojolicious::Plugin"; use Mojo::ByteStream; diff --git a/lib/pause_2025/PAUSE/Web/Plugin/UserRegistration.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/UserRegistration.pm similarity index 98% rename from lib/pause_2025/PAUSE/Web/Plugin/UserRegistration.pm rename to lib/pause_2025/PAUSE/Web2025/Plugin/UserRegistration.pm index d592228c4..af8df0e09 100644 --- a/lib/pause_2025/PAUSE/Web/Plugin/UserRegistration.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/UserRegistration.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Plugin::UserRegistration; +package PAUSE::Web2025::Plugin::UserRegistration; use Mojo::Base "Mojolicious::Plugin"; use PAUSE::Crypt; @@ -67,7 +67,7 @@ sub _set_onetime_password { my $dbh = $mgr->authen_connect; local($dbh->{RaiseError}) = 0; my $rc = $dbh->do($sql,undef,$userid,$pwenc,$email,1,time,$pause->{User}{userid}); - die PAUSE::Web::Exception + die PAUSE::Web2025::Exception ->new(ERROR => [qq{Query [$sql] failed. Reason:}, $DBI::errstr, diff --git a/lib/pause_2025/PAUSE/Web/Plugin/WrapAction.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/WrapAction.pm similarity index 93% rename from lib/pause_2025/PAUSE/Web/Plugin/WrapAction.pm rename to lib/pause_2025/PAUSE/Web2025/Plugin/WrapAction.pm index c7ced54fd..d25997b7d 100644 --- a/lib/pause_2025/PAUSE/Web/Plugin/WrapAction.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/WrapAction.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Plugin::WrapAction; +package PAUSE::Web2025::Plugin::WrapAction; use Mojo::Base "Mojolicious::Plugin"; use HTTP::Status qw/:constants status_message/; @@ -20,7 +20,7 @@ sub _wrap { my $res = eval { $next->(); }; if (my $e = $@) { - if (UNIVERSAL::isa($e, "PAUSE::Web::Exception")) { + if (UNIVERSAL::isa($e, "PAUSE::Web2025::Exception")) { if ($e->{ERROR}) { $e->{ERROR} = [ $e->{ERROR} ] unless ref $e->{ERROR} eq 'ARRAY'; push @{$pause->{ERROR}}, @{$e->{ERROR}}; diff --git a/lib/pause_2025/PAUSE/Web/Util/Encode.pm b/lib/pause_2025/PAUSE/Web2025/Util/Encode.pm similarity index 97% rename from lib/pause_2025/PAUSE/Web/Util/Encode.pm rename to lib/pause_2025/PAUSE/Web2025/Util/Encode.pm index bf66e51c3..4d0794d51 100644 --- a/lib/pause_2025/PAUSE/Web/Util/Encode.pm +++ b/lib/pause_2025/PAUSE/Web2025/Util/Encode.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Util::Encode; +package PAUSE::Web2025::Util::Encode; # XXX: Should be replaced with plain Encode eventually diff --git a/lib/pause_2025/PAUSE/Web/Util/RewriteXHTML.pm b/lib/pause_2025/PAUSE/Web2025/Util/RewriteXHTML.pm similarity index 90% rename from lib/pause_2025/PAUSE/Web/Util/RewriteXHTML.pm rename to lib/pause_2025/PAUSE/Web2025/Util/RewriteXHTML.pm index a12fef82c..4acef952d 100644 --- a/lib/pause_2025/PAUSE/Web/Util/RewriteXHTML.pm +++ b/lib/pause_2025/PAUSE/Web2025/Util/RewriteXHTML.pm @@ -1,4 +1,4 @@ -package PAUSE::Web::Util::RewriteXHTML; +package PAUSE::Web2025::Util::RewriteXHTML; # XXX: Should be rewritten to use HTML5 eventually @@ -12,7 +12,7 @@ sub rewrite { my ($self, $html) = @_; my $w = XML::SAX::Writer->new(Output => \@out); - my $f = PAUSE::Web::Util::RewriteXHTML::Filter->new(Handler => $w); + my $f = PAUSE::Web2025::Util::RewriteXHTML::Filter->new(Handler => $w); my $p = XML::SAX::ParserFactory->parser(Handler => $f); $p->parse_string($html); while ($out[0] =~ /^<[\?\!]/){ # remove XML Declaration, DOCTYPE @@ -23,7 +23,7 @@ sub rewrite { -package PAUSE::Web::Util::RewriteXHTML::Filter; +package PAUSE::Web2025::Util::RewriteXHTML::Filter; use Mojo::Base "XML::SAX::Base"; From 2168789ad8259a73ac77c5d2a4cf61087bdc8487 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 19 Apr 2025 17:10:59 +0900 Subject: [PATCH 03/51] Replace 2017 under lib/pause_2025 with 2025 --- lib/pause_2025/PAUSE/Web2025.pm | 2 +- lib/pause_2025/PAUSE/Web2025/Context.pm | 2 +- lib/pause_2025/templates/layouts/layout.html.ep | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/pause_2025/PAUSE/Web2025.pm b/lib/pause_2025/PAUSE/Web2025.pm index bc9337e52..3e9245b10 100644 --- a/lib/pause_2025/PAUSE/Web2025.pm +++ b/lib/pause_2025/PAUSE/Web2025.pm @@ -26,7 +26,7 @@ sub startup { $app->secrets([sha1_hex($$.time)]); # Fix template path for now - unshift @{$app->renderer->paths}, $app->home->rel_file("lib/pause_2017/templates"); + unshift @{$app->renderer->paths}, $app->home->rel_file("lib/pause_2025/templates"); # Fix static path unshift @{$app->static->paths}, $app->home->rel_file("htdocs"); diff --git a/lib/pause_2025/PAUSE/Web2025/Context.pm b/lib/pause_2025/PAUSE/Web2025/Context.pm index 2bcf547be..c443351a5 100644 --- a/lib/pause_2025/PAUSE/Web2025/Context.pm +++ b/lib/pause_2025/PAUSE/Web2025/Context.pm @@ -30,7 +30,7 @@ sub version { my $self = shift; return $self->{VERSION} if defined $self->{VERSION}; my $version = $VERSION; - for my $m (grep {! m!/Test/!} grep /pause_2017/, keys %INC) { + for my $m (grep {! m!/Test/!} grep /pause_2025/, keys %INC) { $m =~ s|/|::|g; $m =~ s|\.pm$||; my $v = $m->VERSION || 0; diff --git a/lib/pause_2025/templates/layouts/layout.html.ep b/lib/pause_2025/templates/layouts/layout.html.ep index 99176952c..a60e196a9 100644 --- a/lib/pause_2025/templates/layouts/layout.html.ep +++ b/lib/pause_2025/templates/layouts/layout.html.ep @@ -12,7 +12,7 @@ <%= $title %><%= $action %> - + From bf1477c91d407333330b4711798ffa093519a17a Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 19 Apr 2025 17:12:05 +0900 Subject: [PATCH 04/51] Copy pause_2017.css to pause_2025.css --- htdocs/pause/pause_2025.css | 191 ++++++++++++++++++++++++++++++++++++ 1 file changed, 191 insertions(+) create mode 100644 htdocs/pause/pause_2025.css diff --git a/htdocs/pause/pause_2025.css b/htdocs/pause/pause_2025.css new file mode 100644 index 000000000..c6d1ba084 --- /dev/null +++ b/htdocs/pause/pause_2025.css @@ -0,0 +1,191 @@ +body { + color: #000000; + background: white; +} +a { color: #0000cc; } +a:visited { color: #0000bb; } +a:active { color: #ff0000; } +p { padding: 0.5em; margin: 0; } + +h1.logo { font-size:1em; margin: 0; padding: 0 } +div.menu { + padding-right: 0.5em; +} +div.menu p { + margin: 0; + padding: 0.2em 0.3em 0.2em 0.3em; +} +div.menu p.menuheading { padding-top: 0.5em; padding-bottom: 0.3em; } +nav { + border-right: 0.3em #f00 solid; + margin-right: 1em; +} + +.actionresponse { + border: 3px #f3f dashed; + padding: 10px; + margin: 2px; + background-color: #eee; + color: black; +} + +.line1, .line2, .line3 { color: black; } +.line1 { background-color: #ffe0e0; } +.line2 { background-color: #e0ffe0; } +.line3 { background-color: #e0e0ff; } + + +.activemenu { background: #bfb; font-size: small; line-height: 1.5; } +.alternate1 { + background: #f8f8f8; + padding: 0.5em; + } +.alternate2 { + background: #ddd; + padding: 0.5em; + } +.explain { font-size: small; } +.firstheader { margin: 0 0 5%; } +.menuheading { background: white; + font-size: small; } +.menuitem { background: #ddf; font-size: small; line-height: 1.5; } +.menupointer { color: green; } +.messages { text-align: left; border: 2px dashed red; padding: 2ex; } +.userstatus { text-align: center; + font-size: small; + padding: 0.2em; + float: right; } +.statusencr { background: #bfb; + border: green solid 2px; } +.statusunencr { background: #fbb; + border: red solid 2px; } +.xexplain { font-size: x-small; } +a.activemenu { text-decoration: none; } +a.activemenu:hover { text-decoration: underline; } +a.menuitem { text-decoration: none; } +a.menuitem:hover { text-decoration: underline; } +h4.altering { margin: 0 0 12px; } +p.motd { margin: 10px 1in; padding: 5px; color: black; background: yellow; font-size: small; } +p.versionspecial { margin: 10px 1in; padding: 5px; color: white; background: gray; font-size: small; } +a.versionspecial { color: yellow; } +a.versionspecial:hover { color: red; } +p.activemenu { border: green solid 1px; } + +.texttable { border: black solid 1px; } + +.orange_button { + background:#FF6600 none repeat scroll 0%; + border-color:#FFCC99 rgb(102, 51, 0) rgb(51, 51, 0) rgb(255, 153, 102); + border-style:solid; + border-width:1px; + color:#FFFFFF; + font-family:verdana,sans-serif; + font-size:10px; + font-size-adjust:none; + font-stretch:normal; + font-style:normal; + font-variant:normal; + font-weight:bold; + line-height:normal; + margin:0pt; + padding:0pt 3px; + text-decoration:none; +} +#contentBox { + width:600px; + height:auto; +} +td.administration { + border-top: 2px grey solid; + border-left: 2px grey solid; +} + +.sort:after { + width: 0; + height: 0; + border-left: 5px solid transparent; + border-right: 5px solid transparent; + border-bottom: 5px solid transparent; + content:""; + position: relative; + top:-10px; + right:-5px; +} +.sort.asc:after { + width: 0; + height: 0; + border-left: 0.3em solid transparent; + border-right: 0.3em solid transparent; + border-top: 0.3em solid #000; + content:""; + position: relative; + top:0.8em; + right:-0.3em; +} +.sort.desc:after { + width: 0; + height: 0; + border-left: 0.3em solid transparent; + border-right: 0.3em solid transparent; + border-bottom: 0.3em solid #000; + content:""; + position: relative; + top:-0.8em; + right:-0.3em; +} + +.pagination { padding: 0; margin: 0.3em; display: inline-block; } +.pagination li { + display: inline-block; + margin: 0; + padding-right: 0.5em; + font-size: 0.8em; +} +.pagination li.active { + font-weight: bold; +} +.pagination:before { + content: "Page: "; + font-size: 0.8em; +} + +.table.compact { font-size: small; } +.table th,.table td{ padding: 0.3em; text-align: left; vertical-align: top; } +.table tbody>:nth-child(2n-1){ background: #ddd } +input, textarea { background: #fff; } +td.checkbox { padding: 0em; text-align: center; vertical-align: middle; } +.http_upload { background: #e0ffff; } +.url_upload { background: #ffe0ff; } + +p.notice { + font-weight: bold; +} +div.info { + color: #004085; + background-color: #cce5ff; + border-color: #b8daff; +} +div.warning { + color: #856404; + background-color: #fff3cd; + border-color: #ffeeba; +} +div.error { + color: #721c24; + background-color: #f8d7da; + border-color: #f5c6cb; +} +div.messagebox { + padding: 0.75rem 1.25rem; + margin-bottom: 1rem; + border: 1px solid transparent; + border-radius: 0.25rem; +} +td.indexed { + font-weight: bold +} +.row { + margin-left: 1em; + margin-right: 1em; +} +h1.logo img { margin-right: 0.5em; } From d0f2daad01154d94f72aa8ab65ba29ca7906999d Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 19 Apr 2025 17:12:33 +0900 Subject: [PATCH 05/51] Copy app_2017.psgi to app_2025.psgi --- app_2025.psgi | 80 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 80 insertions(+) create mode 100644 app_2025.psgi diff --git a/app_2025.psgi b/app_2025.psgi new file mode 100644 index 000000000..77cd7859a --- /dev/null +++ b/app_2025.psgi @@ -0,0 +1,80 @@ +#!/usr/bin/env perl + +use strict; +use warnings; +use FindBin; +use lib "$FindBin::Bin/lib/", "$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::Web::Context; +use PAUSE::Web; +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::Web::Context->new(root => $AppRoot); +$context->init; + +my $pause_app = PAUSE::Web->new(pause => $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 '/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 4291ef9f22f0c187d70f595c5739b7c4874dc3f7 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 19 Apr 2025 17:19:29 +0900 Subject: [PATCH 06/51] Add lib/pause_2025 to @INC --- app_2025.psgi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/app_2025.psgi b/app_2025.psgi index 77cd7859a..ec3edead0 100644 --- a/app_2025.psgi +++ b/app_2025.psgi @@ -3,7 +3,7 @@ use strict; use warnings; use FindBin; -use lib "$FindBin::Bin/lib/", "$FindBin::Bin/lib/pause_2017", "$FindBin::Bin/../pause-private/lib", "$FindBin::Bin/privatelib"; +use lib "$FindBin::Bin/lib/", "$FindBin::Bin/lib/pause_2017", "$FindBin::Bin/lib/pause_2025", "$FindBin::Bin/../pause-private/lib", "$FindBin::Bin/privatelib"; use Plack::Builder; use Plack::App::Directory::Apaxy; use Path::Tiny; From 1219ad93f394cd14be8d7bfd7b1954f2f595a36f Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 19 Apr 2025 17:21:31 +0900 Subject: [PATCH 07/51] Mount PAUSE::Web2025 app instead of old PAUSE::Web::App::Index --- app_2025.psgi | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/app_2025.psgi b/app_2025.psgi index ec3edead0..c20821849 100644 --- a/app_2025.psgi +++ b/app_2025.psgi @@ -18,6 +18,8 @@ use PAUSE::Web::Context; use PAUSE::Web; use PAUSE::Web::App::Index; use PAUSE::Web::App::Disabled; +use PAUSE::Web2025; +use PAUSE::Web2025::Context; use BSD::Resource (); #BSD::Resource::setrlimit(BSD::Resource::RLIMIT_CPU(), @@ -32,8 +34,11 @@ my $builder = eval { my $context = PAUSE::Web::Context->new(root => $AppRoot); $context->init; +my $context2025 = PAUSE::Web2025::Context->new(root => $AppRoot); +$context2025->init; + my $pause_app = PAUSE::Web->new(pause => $context); -my $index_app = PAUSE::Web::App::Index->new->to_app; +my $pause2025_app = PAUSE::Web2025->new(pause => $context2025); my $disabled_app = PAUSE::Web::App::Disabled->new->to_app; builder { @@ -64,7 +69,9 @@ builder { $pause_app->start('psgi'); }; - mount '/' => builder { $index_app }; + mount '/' => builder { + $pause2025_app->start('psgi'); + }; } }; From b244c027971b5e016a973aa5a068a008681066cf Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 19 Apr 2025 17:25:14 +0900 Subject: [PATCH 08/51] Set pass_through to true for static files from Mojolicious to be served properly --- app_2025.psgi | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/app_2025.psgi b/app_2025.psgi index c20821849..010ecd164 100644 --- a/app_2025.psgi +++ b/app_2025.psgi @@ -52,7 +52,8 @@ builder { # Static files are serverd by us; maybe some day we want to change that enable 'Static', path => qr{(?:(? "$FindBin::Bin/htdocs"; + root => "$FindBin::Bin/htdocs", + pass_through => 1; mount '/pub/PAUSE' => builder { enable '+PAUSE::Web::Middleware::Auth::Basic', context => $context; From ccf3eec487c9074440afb455278f1b74e41afeb7 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 15:55:37 +0900 Subject: [PATCH 09/51] Tweak my_url to accept both ACTION and query parameters Now that we use the path_info to find a route, it may be enough just to move the ACTION to $c->url_for() and keep the rest in the ->query(), but I feel it's easier just to remove ->query and pass all the params to my_url. --- lib/pause_2025/PAUSE/Web2025/Plugin/MyURL.pm | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/lib/pause_2025/PAUSE/Web2025/Plugin/MyURL.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/MyURL.pm index a830837b8..8377e3070 100644 --- a/lib/pause_2025/PAUSE/Web2025/Plugin/MyURL.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/MyURL.pm @@ -11,10 +11,11 @@ sub register { # to generate a url $app->helper(my_url => sub { my $c = shift; - my $url = Mojo::URL->new($c->req->env->{REQUEST_URI}); + my %param = ref $_[0] ? () : @_; my $action = $c->stash('.pause')->{Action}; - my $requested_action = $url->query->param('ACTION') // ''; - $url->query->param(ACTION => $action) if $action && $action ne $requested_action; + my $requested_action = $param{ACTION} ? delete $param{ACTION} : ''; + my $url = $c->url_for($action && $action ne $requested_action ? $action : $requested_action); + $url->query(ref $_[0] ? $_[0] : %param); $url->query->remove('ABRA'); $url; }); From 927711ece5bb8210ce51ac4f650849bff1a93502 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 16:06:08 +0900 Subject: [PATCH 10/51] Modify my_full_url as well For the time being, let's use $c->my_url() and tweak the result, but it might be better to use $c->url_for here as well. --- lib/pause_2025/PAUSE/Web2025/Plugin/MyURL.pm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lib/pause_2025/PAUSE/Web2025/Plugin/MyURL.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/MyURL.pm index 8377e3070..98bbfa355 100644 --- a/lib/pause_2025/PAUSE/Web2025/Plugin/MyURL.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/MyURL.pm @@ -21,7 +21,10 @@ sub register { }); $app->helper(my_full_url => sub { my $c = shift; - my $url = Mojo::URL->new($c->req->env->{REQUEST_URI})->base($c->req->url->to_abs->base)->to_abs; + my $url = $c->req->url->clone->to_abs; + $url->query->pairs([]); + my $path_query = $c->my_url(@_); + $url->path_query($path_query); $url->query->remove('ABRA'); $url; }); From 5a56f1b080227a2ff271589a2b3e38e3bc66695c Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 16:13:46 +0900 Subject: [PATCH 11/51] Remove ->query from my_(full_)url and pass the parameters to them --- lib/pause_2025/templates/_user_menu.html.ep | 4 ++-- lib/pause_2025/templates/admin/email_for_admin.html.ep | 2 +- .../templates/admin/manage_id/manage.html.ep | 4 ++-- lib/pause_2025/templates/admin/user/add.html.ep | 2 +- .../email/admin/user/onetime_password.email.ep | 2 +- .../templates/email/admin/user/welcome_user.email.ep | 4 ++-- lib/pause_2025/templates/email/public/mailpw.email.ep | 4 ++-- .../templates/email/public/request_id.email.ep | 8 ++++---- .../templates/email/user/delete_files.email.ep | 4 ++-- lib/pause_2025/templates/public/admin.html.ep | 2 +- lib/pause_2025/templates/public/pumpkin.html.ep | 2 +- .../user/distperms/giveup_dist_comaint.html.ep | 2 +- .../templates/user/distperms/make_dist_comaint.html.ep | 6 +++--- .../templates/user/distperms/move_dist_primary.html.ep | 4 ++-- lib/pause_2025/templates/user/distperms/peek.html.ep | 10 +++++----- .../user/distperms/remove_dist_comaint.html.ep | 2 +- .../user/distperms/remove_dist_primary.html.ep | 8 ++++---- .../templates/user/perms/_share_makeco.html.ep | 6 +++--- .../templates/user/perms/_share_movepr.html.ep | 4 ++-- .../templates/user/perms/_share_remocos.html.ep | 2 +- .../templates/user/perms/_share_remome.html.ep | 2 +- .../templates/user/perms/_share_remopr.html.ep | 4 ++-- .../templates/user/perms/giveup_comaint.html.ep | 2 +- .../templates/user/perms/make_comaint.html.ep | 6 +++--- .../templates/user/perms/move_primary.html.ep | 4 ++-- lib/pause_2025/templates/user/perms/peek.html.ep | 8 ++++---- .../templates/user/perms/remove_comaint.html.ep | 2 +- .../templates/user/perms/remove_primary.html.ep | 8 ++++---- lib/pause_2025/templates/user/uri/_continued.html.ep | 4 ++-- lib/pause_2025/templates/user/uri/add.html.ep | 4 ++-- 30 files changed, 63 insertions(+), 63 deletions(-) diff --git a/lib/pause_2025/templates/_user_menu.html.ep b/lib/pause_2025/templates/_user_menu.html.ep index 279e193af..d29d78327 100644 --- a/lib/pause_2025/templates/_user_menu.html.ep +++ b/lib/pause_2025/templates/_user_menu.html.ep @@ -14,7 +14,7 @@
% if ($is_public) { % my $scheme = $PAUSE::Config->{TESTHOST_SCHEMA} ? $PAUSE::Config->{TESTHOST_SCHEMA} : "https"; -

Log in

+

Log in

% } % for my $group (@offer_groups) { % last if $group eq "user" and !$user->{userid}; @@ -39,7 +39,7 @@ % } % } % my $menu_class = ($action->{name} eq $pause->{Action}) ? "activemenu" : "menuitem"; -

<% if ($action->{name} eq $pause->{Action}) { %>> <% } %><%= $verbose %>

+

<% if ($action->{name} eq $pause->{Action}) { %>> <% } %><%= $verbose %>

% } % }
diff --git a/lib/pause_2025/templates/admin/email_for_admin.html.ep b/lib/pause_2025/templates/admin/email_for_admin.html.ep index d1dad4034..a5d2f0396 100644 --- a/lib/pause_2025/templates/admin/email_for_admin.html.ep +++ b/lib/pause_2025/templates/admin/email_for_admin.html.ep @@ -22,7 +22,7 @@ -

"YAML") %>" style="text-decoration: none;">YAML +

"YAML") %>" style="text-decoration: none;">YAML

% content_for javascript => begin diff --git a/lib/pause_2025/templates/admin/manage_id/manage.html.ep b/lib/pause_2025/templates/admin/manage_id/manage.html.ep index 7636c12da..555724a7b 100644 --- a/lib/pause_2025/templates/admin/manage_id/manage.html.ep +++ b/lib/pause_2025/templates/admin/manage_id/manage.html.ep @@ -29,13 +29,13 @@ $json; } %> - (exists $ALL{$k}{session}{APPLY}{fullname} ? "add_user" : "add_mod"), USERID => $ALL{$k}{session}{_session_id}, (exists $ALL{$k}{session}{APPLY}{fullname} ? "SUBMIT_pause99_add_user_sub" : "SUBMIT_pause99_add_mod_preview") => 1 ) %>">Go To Registration
- "manage_id_requests", subaction => "delete", USERID => $ALL{$k}{session}{_session_id}, diff --git a/lib/pause_2025/templates/admin/user/add.html.ep b/lib/pause_2025/templates/admin/user/add.html.ep index 33e1d3d9b..6cfef7230 100644 --- a/lib/pause_2025/templates/admin/user/add.html.ep +++ b/lib/pause_2025/templates/admin/user/add.html.ep @@ -195,7 +195,7 @@ subscribe information if this user is a mailing list
-

If this is a bad request: "manage_id_requests", subaction => "delete", USERID => $pause->{userid}, diff --git a/lib/pause_2025/templates/email/admin/user/onetime_password.email.ep b/lib/pause_2025/templates/email/admin/user/onetime_password.email.ep index 5b7aee6e6..c9708c173 100644 --- a/lib/pause_2025/templates/email/admin/user/onetime_password.email.ep +++ b/lib/pause_2025/templates/email/admin/user/onetime_password.email.ep @@ -12,7 +12,7 @@ assigned to you a change-password-only-password that enables you to pick your own password. This password is "<%== $pause->{onetime} %>" (without the enclosing quotes). Please visit - <%== my_full_url->path("/pause/authenquery")->query(ACTION => "change_passwd")->scheme("https") %> + <%== my_full_url(ACTION => "change_passwd")->scheme("https") %> and use this password to initialize your account in the authentication database. Once you have entered your password there, your one-time diff --git a/lib/pause_2025/templates/email/admin/user/welcome_user.email.ep b/lib/pause_2025/templates/email/admin/user/welcome_user.email.ep index 0640e15c2..293aba8c7 100644 --- a/lib/pause_2025/templates/email/admin/user/welcome_user.email.ep +++ b/lib/pause_2025/templates/email/admin/user/welcome_user.email.ep @@ -23,9 +23,9 @@ Please note that your email address is exposed in various listings and database dumps. You can register with both a public and a secret email if you want to protect yourself from SPAM. If you want to do this, please visit - <%== my_full_url->path("/pause/authenquery")->query(ACTION => "edit_cred" )->scheme("https") %> + <%== my_full_url(ACTION => "edit_cred" )->scheme("https") %> or - <%== my_full_url->path("/pause/authenquery")->query(ACTION => "edit_cred" )->scheme("http") %> + <%== my_full_url(ACTION => "edit_cred" )->scheme("http") %> If you need any further information, please visit $CPAN/modules/04pause.html. diff --git a/lib/pause_2025/templates/email/public/mailpw.email.ep b/lib/pause_2025/templates/email/public/mailpw.email.ep index 761df49a8..8e3d9b36e 100644 --- a/lib/pause_2025/templates/email/public/mailpw.email.ep +++ b/lib/pause_2025/templates/email/public/mailpw.email.ep @@ -9,14 +9,14 @@ take more precautions to prevent abuse.) Somebody, probably you, has visited the URL - <%== my_full_url->query(ACTION => "mailpw") %> + <%== my_full_url(ACTION => "mailpw") %> and asked that you, "<%= $pause->{mailpw_userid} %>", should get a token that enables the setting of a new password. Here it is (please watch out for line wrapping errors of your mail reader and other cut and paste errors, this URL must not contain any spaces): - <%== my_full_url->path("/pause/query")->query(ACTION => "change_passwd", ABRA => "$pause->{mailpw_userid}.$pause->{passwd}")->scheme("https") %> + <%== my_full_url(ACTION => "change_passwd", ABRA => "$pause->{mailpw_userid}.$pause->{passwd}")->scheme("https") %> Please visit this URL, it should open you the door to a password changer that lets you set a new password for yourself. This token diff --git a/lib/pause_2025/templates/email/public/request_id.email.ep b/lib/pause_2025/templates/email/public/request_id.email.ep index 965f616e0..0da2a780a 100644 --- a/lib/pause_2025/templates/email/public/request_id.email.ep +++ b/lib/pause_2025/templates/email/public/request_id.email.ep @@ -14,12 +14,12 @@ homepage: <%== $pause->{homepage} %> The following links are only valid for PAUSE maintainers: Registration form with editing capabilities: - <%== my_full_url->path("/pause/authenquery")->scheme('https')->query( + <%== my_full_url( ACTION => "add_user", USERID => $pause->{session_id}, - SUBMIT_pause99_add_user_sub => 1) %> + SUBMIT_pause99_add_user_sub => 1)->scheme('https') %> Immediate (one click) registration: - <%== my_full_url->path("/pause/authenquery")->scheme('https')->query( + <%== my_full_url( ACTION => "add_user", USERID => $pause->{session_id}, - SUBMIT_pause99_add_user_Definitely => 1 ) %> + SUBMIT_pause99_add_user_Definitely => 1 )->scheme('https') %> diff --git a/lib/pause_2025/templates/email/user/delete_files.email.ep b/lib/pause_2025/templates/email/user/delete_files.email.ep index ca74814e9..5fada0747 100644 --- a/lib/pause_2025/templates/email/user/delete_files.email.ep +++ b/lib/pause_2025/templates/email/user/delete_files.email.ep @@ -7,8 +7,8 @@ According to a request entered by <%== $pause->{User}{fullname} %> the following files and the symlinks pointing to them have been scheduled for deletion. They will expire after 72 hours and then be deleted by a cronjob. Until then you can undelete them via -<%== my_full_url->path("/pause/authenquery")->query(ACTION => "delete_files")->scheme("https") %> or -<%== my_full_url->path("/pause/authenquery")->query(ACTION => "delete_files")->scheme("http") %> +<%== my_full_url(ACTION => "delete_files")->scheme("https") %> or +<%== my_full_url(ACTION => "delete_files")->scheme("http") %> % end <%== $pause->{blurb} %> diff --git a/lib/pause_2025/templates/public/admin.html.ep b/lib/pause_2025/templates/public/admin.html.ep index 4b2a11ad7..461079328 100644 --- a/lib/pause_2025/templates/public/admin.html.ep +++ b/lib/pause_2025/templates/public/admin.html.ep @@ -3,6 +3,6 @@

Query the grouptable table for who is an admin bit holder

Registered admins: <%= join ", ", @{$pause->{admins} || []} %>

-

"YAML") %>" style="text-decoration: none;"> +

"YAML") %>" style="text-decoration: none;"> YAML

diff --git a/lib/pause_2025/templates/public/pumpkin.html.ep b/lib/pause_2025/templates/public/pumpkin.html.ep index bdb2bb324..f267edf79 100644 --- a/lib/pause_2025/templates/public/pumpkin.html.ep +++ b/lib/pause_2025/templates/public/pumpkin.html.ep @@ -3,6 +3,6 @@

Query the grouptable table for who is a pumpkin bit holder

Registered pumpkins: <%= join ", ", @{$pause->{pumpkins} || []} %>

-

"YAML") %>" style="text-decoration: none;"> +

"YAML") %>" style="text-decoration: none;"> YAML

diff --git a/lib/pause_2025/templates/user/distperms/giveup_dist_comaint.html.ep b/lib/pause_2025/templates/user/distperms/giveup_dist_comaint.html.ep index 2e64cf7d4..8cbf5ac12 100644 --- a/lib/pause_2025/templates/user/distperms/giveup_dist_comaint.html.ep +++ b/lib/pause_2025/templates/user/distperms/giveup_dist_comaint.html.ep @@ -32,7 +32,7 @@ the co-maintainer table and press Give Up

If you need finer control (eg. to give up comaintainership for a removed module), visit - + Give up Co-maintainership status per module page.

Select one or more distributions:

diff --git a/lib/pause_2025/templates/user/distperms/make_dist_comaint.html.ep b/lib/pause_2025/templates/user/distperms/make_dist_comaint.html.ep index ae228259a..78fc4d474 100644 --- a/lib/pause_2025/templates/user/distperms/make_dist_comaint.html.ep +++ b/lib/pause_2025/templates/user/distperms/make_dist_comaint.html.ep @@ -38,16 +38,16 @@ into the text field and press Make Co-Maintainer

If you are open to someone else asking for your first-come permissions, but you wish to decide on any such request, you can give a co-maint to a special user called -HANDOFF.

+HANDOFF.

You can also grant co-maint to -NEEDHELP +NEEDHELP if you would like additional volunteers to help you work on a particular module.

If you need finer control (eg. to add comaintainers for only a small part of a distribution just to allow them to handle RT tickets while prohibiting them to upload the distribution), visit - + Add Comaintainers per module page.

Select one or more distributions:

diff --git a/lib/pause_2025/templates/user/distperms/move_dist_primary.html.ep b/lib/pause_2025/templates/user/distperms/move_dist_primary.html.ep index 36c1441a2..b950ba585 100644 --- a/lib/pause_2025/templates/user/distperms/move_dist_primary.html.ep +++ b/lib/pause_2025/templates/user/distperms/move_dist_primary.html.ep @@ -32,7 +32,7 @@ maintainership status, enter the CPAN userid of the new maintainer into the text field and press Pass Maintainership Status. Note: you keep co-maintainer status after this move. If you want to get rid of that too, please visit Give up +href="<%= my_url(ACTION => 'remove_dist_primary') %>">Give up co-maintainership status next.

You can only transfer what you actually own. @@ -42,7 +42,7 @@ their permissions as well.

If you need finer control (eg. to transfer only a small part of a distribution you and other people own, for clarity's sake), visit - + Transfer Primary Permissions per module page.

Select one or more distributions:

diff --git a/lib/pause_2025/templates/user/distperms/peek.html.ep b/lib/pause_2025/templates/user/distperms/peek.html.ep index 132e6c29e..d40b579b4 100644 --- a/lib/pause_2025/templates/user/distperms/peek.html.ep +++ b/lib/pause_2025/templates/user/distperms/peek.html.ep @@ -27,7 +27,7 @@ not per distribution. So you might not have enough permission to upload a distribution or grant permissions to other people if you are listed here (when you have permissions for only a part of the distribution). If you want more detailed -information, visit +information, visit View permission per module page.

The @@ -61,7 +61,7 @@ can be corrected.--Thank you!

% for my $row (@{$pause->{rows}}) { - $row->[0], pause99_peek_dist_perms_sub => 1, @@ -69,7 +69,7 @@ can be corrected.--Thank you!

% my @owners = split /,/, $row->[1] // ''; % while(my $owner = shift @owners) { - "a", pause99_peek_dist_perms_query => $owner, pause99_peek_dist_perms_sub => 1, @@ -79,7 +79,7 @@ can be corrected.--Thank you!

% my @comaints = split /,/, $row->[2] // ''; % while(my $comaint = shift @comaints) { - "a", pause99_peek_dist_perms_query => $comaint, pause99_peek_dist_perms_sub => 1, @@ -90,7 +90,7 @@ can be corrected.--Thank you!

% } -

"YAML", pause99_peek_dist_perms_sub => 1, pause99_peek_dist_perms_by => param("pause99_peek_dist_perms_by"), diff --git a/lib/pause_2025/templates/user/distperms/remove_dist_comaint.html.ep b/lib/pause_2025/templates/user/distperms/remove_dist_comaint.html.ep index 09ccc3d2a..eb406ff69 100644 --- a/lib/pause_2025/templates/user/distperms/remove_dist_comaint.html.ep +++ b/lib/pause_2025/templates/user/distperms/remove_dist_comaint.html.ep @@ -37,7 +37,7 @@ remove and press Remove

If you need finer control (eg. to remove comaintainers only for a small part of a distribution, or remove comaintainers for a removed module), visit - + Remove Comaintainers per module page.

diff --git a/lib/pause_2025/templates/user/distperms/remove_dist_primary.html.ep b/lib/pause_2025/templates/user/distperms/remove_dist_primary.html.ep index 670c18667..582b04862 100644 --- a/lib/pause_2025/templates/user/distperms/remove_dist_primary.html.ep +++ b/lib/pause_2025/templates/user/distperms/remove_dist_primary.html.ep @@ -31,19 +31,19 @@ want to give up primary maintainership status and press Give Up Maintainership Status. Note: you keep co-maintainer status after this move. If you want to get rid of that too, -please visit ">Give up +please visit ">Give up co-maintainership status next.

Giving up primary permissions now means that the permissions are transferred to a special user called -ADOPTME. +ADOPTME.

You can only give up what you actually own. If multiple owners are listed, those owners keep their primary maintainership for their part of the distribution. In this case, you are strongly advised to -">transfer your primary permissions +">transfer your primary permissions to one of the other owners.

@@ -53,7 +53,7 @@ please email the PAUSE admins at modules@cpan.

If you need finer control (eg. to give up only a small part of a distribution for whatever reasons), visit - + <%= $c->app->pause->config->action('remove_primary')->{verb} %> page.

Select one or more distributions:

diff --git a/lib/pause_2025/templates/user/perms/_share_makeco.html.ep b/lib/pause_2025/templates/user/perms/_share_makeco.html.ep index 90f1f1ef7..bda6b865c 100644 --- a/lib/pause_2025/templates/user/perms/_share_makeco.html.ep +++ b/lib/pause_2025/templates/user/perms/_share_makeco.html.ep @@ -34,14 +34,14 @@ into the text field and press Make Co-Maintainer

If you are open to someone else asking for your first-come permissions, but you wish to decide on any such request, you can give a co-maint to a special user called -HANDOFF.

+HANDOFF.

You can also grant co-maint to -NEEDHELP +NEEDHELP if you would like additional volunteers to help you work on a particular module.

If you want to add comaintainers for all the modules in a -distribution, visit +distribution, visit Add Comaintainers per distribution page.

Select one or more namespaces:

diff --git a/lib/pause_2025/templates/user/perms/_share_movepr.html.ep b/lib/pause_2025/templates/user/perms/_share_movepr.html.ep index 862cbfd62..d7239e0cc 100644 --- a/lib/pause_2025/templates/user/perms/_share_movepr.html.ep +++ b/lib/pause_2025/templates/user/perms/_share_movepr.html.ep @@ -27,11 +27,11 @@ maintainership status, enter the CPAN userid of the new maintainer into the text field and press Pass Maintainership Status. Note: you keep co-maintainer status after this move. If you want to get rid of that too, please visit Give up +href="<%= my_url([pause99_share_perms_remome => 1]) %>">Give up co-maintainership status next.

If you want to transfer all the modules in a distribution, visit - + Transfer Primary Permissions per distribution page.

Select one or more namespaces:

diff --git a/lib/pause_2025/templates/user/perms/_share_remocos.html.ep b/lib/pause_2025/templates/user/perms/_share_remocos.html.ep index 694d58ddf..498c83c0b 100644 --- a/lib/pause_2025/templates/user/perms/_share_remocos.html.ep +++ b/lib/pause_2025/templates/user/perms/_share_remocos.html.ep @@ -31,7 +31,7 @@ remove and press Remove

If you want to remove comaintainers from all the modules in a distribution, visit - + Remove Comaintainers per distribution page.

<%= select_field "pause99_share_perms_remocos_tuples" => $pause->{mods}, diff --git a/lib/pause_2025/templates/user/perms/_share_remome.html.ep b/lib/pause_2025/templates/user/perms/_share_remome.html.ep index 39b8dee96..b09b655df 100644 --- a/lib/pause_2025/templates/user/perms/_share_remome.html.ep +++ b/lib/pause_2025/templates/user/perms/_share_remome.html.ep @@ -27,7 +27,7 @@ the co-maintainer table and press Give Up

If you want to give up comaintainership for all the modules in a distribution, visit - + Give up Co-maintainership status per distribution page.

Select one or more namespaces:

diff --git a/lib/pause_2025/templates/user/perms/_share_remopr.html.ep b/lib/pause_2025/templates/user/perms/_share_remopr.html.ep index 3dbee1681..d5d3c4526 100644 --- a/lib/pause_2025/templates/user/perms/_share_remopr.html.ep +++ b/lib/pause_2025/templates/user/perms/_share_remopr.html.ep @@ -26,12 +26,12 @@ want to give up primary maintainership status and press Give Up Maintainership Status. Note: you keep co-maintainer status after this move. If you want to get rid of that too, -please visit Give up +please visit Give up co-maintainership status next.

If you want to give up comaintainership for all the modules in a distribution, visit - + Give up Co-maintainership status per distribution page.

Select one or more namespaces:

diff --git a/lib/pause_2025/templates/user/perms/giveup_comaint.html.ep b/lib/pause_2025/templates/user/perms/giveup_comaint.html.ep index a1d10c908..88cd9549b 100644 --- a/lib/pause_2025/templates/user/perms/giveup_comaint.html.ep +++ b/lib/pause_2025/templates/user/perms/giveup_comaint.html.ep @@ -32,7 +32,7 @@ the co-maintainer table and press Give Up

If you want to give up comaintainership for all the modules in a distribution, visit - + Give up Co-maintainership status per distribution page.

Select one or more namespaces:

diff --git a/lib/pause_2025/templates/user/perms/make_comaint.html.ep b/lib/pause_2025/templates/user/perms/make_comaint.html.ep index 33cd2092b..a05bf3fee 100644 --- a/lib/pause_2025/templates/user/perms/make_comaint.html.ep +++ b/lib/pause_2025/templates/user/perms/make_comaint.html.ep @@ -38,14 +38,14 @@ into the text field and press Make Co-Maintainer

If you are open to someone else asking for your first-come permissions, but you wish to decide on any such request, you can give a co-maint to a special user called -HANDOFF.

+HANDOFF.

You can also grant co-maint to -NEEDHELP +NEEDHELP if you would like additional volunteers to help you work on a particular module.

If you want to add comaintainers for all the modules in a -distribution, visit +distribution, visit Add Comaintainers per distribution page.

Select one or more namespaces:

diff --git a/lib/pause_2025/templates/user/perms/move_primary.html.ep b/lib/pause_2025/templates/user/perms/move_primary.html.ep index faa112646..94505b229 100644 --- a/lib/pause_2025/templates/user/perms/move_primary.html.ep +++ b/lib/pause_2025/templates/user/perms/move_primary.html.ep @@ -32,11 +32,11 @@ maintainership status, enter the CPAN userid of the new maintainer into the text field and press Pass Maintainership Status. Note: you keep co-maintainer status after this move. If you want to get rid of that too, please visit Give up +href="<%= my_url(ACTION => 'remove_primary') %>">Give up co-maintainership status next.

If you want to transfer all the modules in a distribution, visit - + Transfer Primary Permissions per distribution page.

Select one or more namespaces:

diff --git a/lib/pause_2025/templates/user/perms/peek.html.ep b/lib/pause_2025/templates/user/perms/peek.html.ep index d0d0d5ea8..06907ad64 100644 --- a/lib/pause_2025/templates/user/perms/peek.html.ep +++ b/lib/pause_2025/templates/user/perms/peek.html.ep @@ -22,7 +22,7 @@ upload a module in that namespace but also be accepted by the indexer. In other words, the indexer will not ignore uploads for that namespace by that person.

-

If the list is too long, visit +

If the list is too long, visit View permission per distribution page.

The @@ -56,12 +56,12 @@ can be corrected.--Thank you!

% for my $row (@{$pause->{rows}}) { - $row->[0], pause99_peek_perms_sub => 1, ]) %>"><%= $row->[0] %> - $row->[1], pause99_peek_perms_sub => 1, @@ -72,7 +72,7 @@ can be corrected.--Thank you!

% } -

"YAML", pause99_peek_perms_sub => 1, pause99_peek_perms_by => param("pause99_peek_perms_by"), diff --git a/lib/pause_2025/templates/user/perms/remove_comaint.html.ep b/lib/pause_2025/templates/user/perms/remove_comaint.html.ep index 3cc4eeb72..df8cbb91b 100644 --- a/lib/pause_2025/templates/user/perms/remove_comaint.html.ep +++ b/lib/pause_2025/templates/user/perms/remove_comaint.html.ep @@ -36,7 +36,7 @@ remove and press Remove

If you want to remove comaintainers from all the modules in a distribution, visit - + Remove Comaintainers per distribution page.

diff --git a/lib/pause_2025/templates/user/perms/remove_primary.html.ep b/lib/pause_2025/templates/user/perms/remove_primary.html.ep index 778a7cd0a..04ded54b8 100644 --- a/lib/pause_2025/templates/user/perms/remove_primary.html.ep +++ b/lib/pause_2025/templates/user/perms/remove_primary.html.ep @@ -31,16 +31,16 @@ want to give up primary maintainership status and press Give Up Maintainership Status. Note: you keep co-maintainer status after this move. If you want to get rid of that too, -please visit ">Give up +please visit ">Give up co-maintainership status next.

Giving up primary permissions now means that the permissions are transferred to a special user called -ADOPTME.

+ADOPTME.

If multiple owners are listed, those owners keep their primary maintainership for those modules. In this case, you are strongly advised to -">transfer your primary permissions +">transfer your primary permissions to one of the other owners.

@@ -49,7 +49,7 @@ please email the PAUSE admins at modules@cpan.

If you want to give up all the modules in a distribution, visit - + <%= $c->app->pause->config->action('remove_dist_primary')->{verb} %> page.

Select one or more namespaces:

diff --git a/lib/pause_2025/templates/user/uri/_continued.html.ep b/lib/pause_2025/templates/user/uri/_continued.html.ep index 6a797af33..132845051 100644 --- a/lib/pause_2025/templates/user/uri/_continued.html.ep +++ b/lib/pause_2025/templates/user/uri/_continued.html.ep @@ -20,7 +20,7 @@ here in case you want to upload further files.

Please tidy up your homedir: CPAN is getting larger every day which is nice but usually there is no need to keep old an outdated version of a module on several hundred mirrors. Please consider ">removing old versions of +href="<%= my_url(ACTION => "delete_files") %>">removing old versions of your module from PAUSE and CPAN. If you are worried that someone might need an old version, it can always be found on the backpan @@ -30,7 +30,7 @@ href="http://backpan.cpan.org/authors/id/<%= $pause->{userhome} %>/">backpan href="<%= $pause->{usrdir} %>"><%= $pause->{usrdir} %>. If something's wrong, please check the logfile of the daemon: see the tail of it with <%= $pause->{tailurl} %>. If you already know what's going wrong, you -may wish to visit the ">repair +may wish to visit the ">repair tool for pending uploads.

% } else { diff --git a/lib/pause_2025/templates/user/uri/add.html.ep b/lib/pause_2025/templates/user/uri/add.html.ep index 6ebadc673..1e484ad13 100644 --- a/lib/pause_2025/templates/user/uri/add.html.ep +++ b/lib/pause_2025/templates/user/uri/add.html.ep @@ -44,14 +44,14 @@ HTTP upload: enter the filename in the lower text field. it may be due to the fact that your browser can't handle multipart/form-data forms that support file upload. In such a case, please retry to access this 0) %>">file-upload-disabled form.

+href="<%= my_url(ACTION => "add_uri", CAN_MULTIPART => 0) %>">file-upload-disabled form.

% } else {

HTTP Upload: As you do not seem to want HTTP upload enabled, we do not offer it. If this is not what you want, try to - 1) %>">explicitly enable HTTP upload.

+ 1) %>">explicitly enable HTTP upload.

% } From eeeb2bce679783ec8d7bbcf41c9bd395afa918e7 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 16:15:55 +0900 Subject: [PATCH 12/51] Just use $c->url_for for the menu links on the left my_url() may use a different action stored in the stash, but the menu links do not need such a trick. --- lib/pause_2025/templates/_user_menu.html.ep | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/pause_2025/templates/_user_menu.html.ep b/lib/pause_2025/templates/_user_menu.html.ep index d29d78327..be296d4fe 100644 --- a/lib/pause_2025/templates/_user_menu.html.ep +++ b/lib/pause_2025/templates/_user_menu.html.ep @@ -39,7 +39,7 @@ % } % } % my $menu_class = ($action->{name} eq $pause->{Action}) ? "activemenu" : "menuitem"; -

<% if ($action->{name} eq $pause->{Action}) { %>> <% } %><%= $verbose %>

+

<% if ($action->{name} eq $pause->{Action}) { %>> <% } %><%= $verbose %>

% } % }
From b65a0c77a6db0ec874ba3da0c0c9a561e168ab80 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 16:19:04 +0900 Subject: [PATCH 13/51] Move ABRA back to ->query() as my_url removes it internally --- lib/pause_2025/templates/email/public/mailpw.email.ep | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/pause_2025/templates/email/public/mailpw.email.ep b/lib/pause_2025/templates/email/public/mailpw.email.ep index 8e3d9b36e..8df994157 100644 --- a/lib/pause_2025/templates/email/public/mailpw.email.ep +++ b/lib/pause_2025/templates/email/public/mailpw.email.ep @@ -16,7 +16,7 @@ setting of a new password. Here it is (please watch out for line wrapping errors of your mail reader and other cut and paste errors, this URL must not contain any spaces): - <%== my_full_url(ACTION => "change_passwd", ABRA => "$pause->{mailpw_userid}.$pause->{passwd}")->scheme("https") %> + <%== my_full_url(ACTION => "change_passwd")->query(ABRA => "$pause->{mailpw_userid}.$pause->{passwd}")->scheme("https") %> Please visit this URL, it should open you the door to a password changer that lets you set a new password for yourself. This token From 9af4b1b8c67229822b9096c3d1f76e219f2488d2 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 16:21:03 +0900 Subject: [PATCH 14/51] Move links to list.min.js under /pause As pause_2025 mounts on the /, not on the /pause, the links also need to be modified --- lib/pause_2025/templates/admin/email_for_admin.html.ep | 2 +- lib/pause_2025/templates/admin/manage_id/manage.html.ep | 2 +- lib/pause_2025/templates/mlrepr/show_ml_repr.html.ep | 2 +- .../templates/user/distperms/giveup_dist_comaint.html.ep | 2 +- .../templates/user/distperms/make_dist_comaint.html.ep | 2 +- .../templates/user/distperms/move_dist_primary.html.ep | 2 +- lib/pause_2025/templates/user/distperms/peek.html.ep | 2 +- .../templates/user/distperms/remove_dist_comaint.html.ep | 2 +- .../templates/user/distperms/remove_dist_primary.html.ep | 2 +- lib/pause_2025/templates/user/files/delete.html.ep | 2 +- lib/pause_2025/templates/user/files/show.html.ep | 2 +- lib/pause_2025/templates/user/perms/giveup_comaint.html.ep | 2 +- lib/pause_2025/templates/user/perms/make_comaint.html.ep | 2 +- lib/pause_2025/templates/user/perms/move_primary.html.ep | 2 +- lib/pause_2025/templates/user/perms/peek.html.ep | 2 +- lib/pause_2025/templates/user/perms/remove_comaint.html.ep | 2 +- lib/pause_2025/templates/user/perms/remove_primary.html.ep | 2 +- lib/pause_2025/templates/user/reindex.html.ep | 2 +- lib/pause_2025/templates/user/reset_version.html.ep | 2 +- lib/pause_2025/templates/user/tail_logfile.html.ep | 2 +- 20 files changed, 20 insertions(+), 20 deletions(-) diff --git a/lib/pause_2025/templates/admin/email_for_admin.html.ep b/lib/pause_2025/templates/admin/email_for_admin.html.ep index a5d2f0396..1562ca147 100644 --- a/lib/pause_2025/templates/admin/email_for_admin.html.ep +++ b/lib/pause_2025/templates/admin/email_for_admin.html.ep @@ -26,7 +26,7 @@

% content_for javascript => begin -%= javascript "/list.min.js" +%= javascript "/pause/list.min.js" %= javascript begin var List = new List('emails', { valueNames: ['userid', 'email'] diff --git a/lib/pause_2025/templates/admin/manage_id/manage.html.ep b/lib/pause_2025/templates/admin/manage_id/manage.html.ep index 555724a7b..717651465 100644 --- a/lib/pause_2025/templates/admin/manage_id/manage.html.ep +++ b/lib/pause_2025/templates/admin/manage_id/manage.html.ep @@ -47,7 +47,7 @@
% content_for javascript => begin -%= javascript "/list.min.js" +%= javascript "/pause/list.min.js" %= javascript begin var requestList = new List('requests', {valueNames: ['type', 'userid', 'session']}); % end diff --git a/lib/pause_2025/templates/mlrepr/show_ml_repr.html.ep b/lib/pause_2025/templates/mlrepr/show_ml_repr.html.ep index d0b7e14f9..bd891e2df 100644 --- a/lib/pause_2025/templates/mlrepr/show_ml_repr.html.ep +++ b/lib/pause_2025/templates/mlrepr/show_ml_repr.html.ep @@ -25,7 +25,7 @@ mailing list.

% content_for javascript => begin -%= javascript "/list.min.js" +%= javascript "/pause/list.min.js" %= javascript begin var userList = new List('users', {valueNames: ['ml', 'userid']}); % end diff --git a/lib/pause_2025/templates/user/distperms/giveup_dist_comaint.html.ep b/lib/pause_2025/templates/user/distperms/giveup_dist_comaint.html.ep index 8cbf5ac12..cf0f272e1 100644 --- a/lib/pause_2025/templates/user/distperms/giveup_dist_comaint.html.ep +++ b/lib/pause_2025/templates/user/distperms/giveup_dist_comaint.html.ep @@ -62,7 +62,7 @@ Give up Co-maintainership status per module page.

value="Give Up">

% content_for javascript => begin -%= javascript "/list.min.js" +%= javascript "/pause/list.min.js" %= javascript begin var List = new List('dists', { valueNames: ['dist','owners'] diff --git a/lib/pause_2025/templates/user/distperms/make_dist_comaint.html.ep b/lib/pause_2025/templates/user/distperms/make_dist_comaint.html.ep index 78fc4d474..9e28b135a 100644 --- a/lib/pause_2025/templates/user/distperms/make_dist_comaint.html.ep +++ b/lib/pause_2025/templates/user/distperms/make_dist_comaint.html.ep @@ -79,7 +79,7 @@ Add Comaintainers per module page.

value="Make Co-Maintainer">

% content_for javascript => begin -%= javascript "/list.min.js" +%= javascript "/pause/list.min.js" %= javascript begin var List = new List('dists', { valueNames: ['dist','owners'] diff --git a/lib/pause_2025/templates/user/distperms/move_dist_primary.html.ep b/lib/pause_2025/templates/user/distperms/move_dist_primary.html.ep index b950ba585..cf151ebb0 100644 --- a/lib/pause_2025/templates/user/distperms/move_dist_primary.html.ep +++ b/lib/pause_2025/templates/user/distperms/move_dist_primary.html.ep @@ -73,7 +73,7 @@ Transfer Primary Permissions per module page.

% content_for javascript => begin -%= javascript "/list.min.js" +%= javascript "/pause/list.min.js" %= javascript begin var List = new List('dists', { valueNames: ['dist', 'owners'] diff --git a/lib/pause_2025/templates/user/distperms/peek.html.ep b/lib/pause_2025/templates/user/distperms/peek.html.ep index d40b579b4..6d3d8b0ab 100644 --- a/lib/pause_2025/templates/user/distperms/peek.html.ep +++ b/lib/pause_2025/templates/user/distperms/peek.html.ep @@ -100,7 +100,7 @@ can be corrected.--Thank you!

% content_for javascript => begin -%= javascript "/list.min.js" +%= javascript "/pause/list.min.js" %= javascript begin var List = new List('perms', { valueNames: ['dist', 'owner', 'comaint'] diff --git a/lib/pause_2025/templates/user/distperms/remove_dist_comaint.html.ep b/lib/pause_2025/templates/user/distperms/remove_dist_comaint.html.ep index eb406ff69..355f92c08 100644 --- a/lib/pause_2025/templates/user/distperms/remove_dist_comaint.html.ep +++ b/lib/pause_2025/templates/user/distperms/remove_dist_comaint.html.ep @@ -66,7 +66,7 @@ Remove Comaintainers per module page.

value="Remove">

% content_for javascript => begin -%= javascript "/list.min.js" +%= javascript "/pause/list.min.js" %= javascript begin var List = new List('dists', { valueNames: ['dist', 'userid'] diff --git a/lib/pause_2025/templates/user/distperms/remove_dist_primary.html.ep b/lib/pause_2025/templates/user/distperms/remove_dist_primary.html.ep index 582b04862..67254d0f7 100644 --- a/lib/pause_2025/templates/user/distperms/remove_dist_primary.html.ep +++ b/lib/pause_2025/templates/user/distperms/remove_dist_primary.html.ep @@ -82,7 +82,7 @@ a distribution for whatever reasons), visit value="Give Up Maintainership Status">

% content_for javascript => begin -%= javascript "/list.min.js" +%= javascript "/pause/list.min.js" %= javascript begin var List = new List('dists', { valueNames: ['dist', 'owners'] diff --git a/lib/pause_2025/templates/user/files/delete.html.ep b/lib/pause_2025/templates/user/files/delete.html.ep index 6bd26d07d..d53a8354c 100644 --- a/lib/pause_2025/templates/user/files/delete.html.ep +++ b/lib/pause_2025/templates/user/files/delete.html.ep @@ -45,7 +45,7 @@

% content_for javascript => begin -%= javascript "/list.min.js" +%= javascript "/pause/list.min.js" %= javascript begin var List = new List('files', { valueNames: ['file', 'size', 'modified'] diff --git a/lib/pause_2025/templates/user/files/show.html.ep b/lib/pause_2025/templates/user/files/show.html.ep index 9bab21d54..de31614d7 100644 --- a/lib/pause_2025/templates/user/files/show.html.ep +++ b/lib/pause_2025/templates/user/files/show.html.ep @@ -30,7 +30,7 @@ % content_for javascript => begin -%= javascript "/list.min.js" +%= javascript "/pause/list.min.js" %= javascript begin var List = new List('files', { valueNames: ['file', 'size', 'modified'] diff --git a/lib/pause_2025/templates/user/perms/giveup_comaint.html.ep b/lib/pause_2025/templates/user/perms/giveup_comaint.html.ep index 88cd9549b..b82d0590e 100644 --- a/lib/pause_2025/templates/user/perms/giveup_comaint.html.ep +++ b/lib/pause_2025/templates/user/perms/giveup_comaint.html.ep @@ -62,7 +62,7 @@ Give up Co-maintainership status per distribution page.

value="Give Up">

% content_for javascript => begin -%= javascript "/list.min.js" +%= javascript "/pause/list.min.js" %= javascript begin var List = new List('packages', { valueNames: ['package', 'dist'] diff --git a/lib/pause_2025/templates/user/perms/make_comaint.html.ep b/lib/pause_2025/templates/user/perms/make_comaint.html.ep index a05bf3fee..8fe4a3ff1 100644 --- a/lib/pause_2025/templates/user/perms/make_comaint.html.ep +++ b/lib/pause_2025/templates/user/perms/make_comaint.html.ep @@ -77,7 +77,7 @@ Add Comaintainers per distribution page.

value="Make Co-Maintainer">

% content_for javascript => begin -%= javascript "/list.min.js" +%= javascript "/pause/list.min.js" %= javascript begin var List = new List('packages', { valueNames: ['package', 'dist'] diff --git a/lib/pause_2025/templates/user/perms/move_primary.html.ep b/lib/pause_2025/templates/user/perms/move_primary.html.ep index 94505b229..5172c4290 100644 --- a/lib/pause_2025/templates/user/perms/move_primary.html.ep +++ b/lib/pause_2025/templates/user/perms/move_primary.html.ep @@ -67,7 +67,7 @@ Transfer Primary Permissions per distribution page.

% content_for javascript => begin -%= javascript "/list.min.js" +%= javascript "/pause/list.min.js" %= javascript begin var List = new List('packages', { valueNames: ['package', 'dist'] diff --git a/lib/pause_2025/templates/user/perms/peek.html.ep b/lib/pause_2025/templates/user/perms/peek.html.ep index 06907ad64..e72d0c28d 100644 --- a/lib/pause_2025/templates/user/perms/peek.html.ep +++ b/lib/pause_2025/templates/user/perms/peek.html.ep @@ -82,7 +82,7 @@ can be corrected.--Thank you!

% content_for javascript => begin -%= javascript "/list.min.js" +%= javascript "/pause/list.min.js" %= javascript begin var List = new List('perms', { valueNames: ['module', 'userid', 'type', 'owner'] diff --git a/lib/pause_2025/templates/user/perms/remove_comaint.html.ep b/lib/pause_2025/templates/user/perms/remove_comaint.html.ep index df8cbb91b..19a3c4f16 100644 --- a/lib/pause_2025/templates/user/perms/remove_comaint.html.ep +++ b/lib/pause_2025/templates/user/perms/remove_comaint.html.ep @@ -67,7 +67,7 @@ Remove Comaintainers per distribution page.

value="Remove">

% content_for javascript => begin -%= javascript "/list.min.js" +%= javascript "/pause/list.min.js" %= javascript begin var List = new List('packages', { valueNames: ['pacakge', 'dist', 'userid'] diff --git a/lib/pause_2025/templates/user/perms/remove_primary.html.ep b/lib/pause_2025/templates/user/perms/remove_primary.html.ep index 04ded54b8..e36a79fcb 100644 --- a/lib/pause_2025/templates/user/perms/remove_primary.html.ep +++ b/lib/pause_2025/templates/user/perms/remove_primary.html.ep @@ -78,7 +78,7 @@ please email the PAUSE admins at modules@cpan. value="Give Up Maintainership Status">

% content_for javascript => begin -%= javascript "/list.min.js" +%= javascript "/pause/list.min.js" %= javascript begin var List = new List('packages', { valueNames: ['package', 'dist'] diff --git a/lib/pause_2025/templates/user/reindex.html.ep b/lib/pause_2025/templates/user/reindex.html.ep index be2863966..31befcf4f 100644 --- a/lib/pause_2025/templates/user/reindex.html.ep +++ b/lib/pause_2025/templates/user/reindex.html.ep @@ -45,7 +45,7 @@

% content_for javascript => begin -%= javascript "/list.min.js" +%= javascript "/pause/list.min.js" %= javascript begin var List = new List('files', { valueNames: ['file'] diff --git a/lib/pause_2025/templates/user/reset_version.html.ep b/lib/pause_2025/templates/user/reset_version.html.ep index 0c649fe5c..32faca254 100644 --- a/lib/pause_2025/templates/user/reset_version.html.ep +++ b/lib/pause_2025/templates/user/reset_version.html.ep @@ -58,7 +58,7 @@ there was a problem.

% content_for javascript => begin -%= javascript "/list.min.js" +%= javascript "/pause/list.min.js" %= javascript begin var List = new List('packages', { valueNames: ['package', 'version', 'dist'] diff --git a/lib/pause_2025/templates/user/tail_logfile.html.ep b/lib/pause_2025/templates/user/tail_logfile.html.ep index b7a469320..84bdab3bd 100644 --- a/lib/pause_2025/templates/user/tail_logfile.html.ep +++ b/lib/pause_2025/templates/user/tail_logfile.html.ep @@ -14,7 +14,7 @@ % content_for javascript => begin -%= javascript "/list.min.js" +%= javascript "/pause/list.min.js" %= javascript begin var logList = new List('logs', {valueNames: ['log']}); % end From 73fce8e609e88f04d54e89e3e451a6a691ca4417 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 16:24:37 +0900 Subject: [PATCH 15/51] Remove FixAction plugin pause_2025 just uses $c->url_for(), so we don't need to "fix" the action --- lib/pause_2025/PAUSE/Web2025.pm | 1 - .../PAUSE/Web2025/Plugin/FixAction.pm | 70 ------------------- 2 files changed, 71 deletions(-) delete mode 100644 lib/pause_2025/PAUSE/Web2025/Plugin/FixAction.pm diff --git a/lib/pause_2025/PAUSE/Web2025.pm b/lib/pause_2025/PAUSE/Web2025.pm index 3e9245b10..16a68bac3 100644 --- a/lib/pause_2025/PAUSE/Web2025.pm +++ b/lib/pause_2025/PAUSE/Web2025.pm @@ -38,7 +38,6 @@ sub startup { $app->plugin("PAUSE::Web2025::Plugin::GetActiveUserRecord"); $app->plugin("PAUSE::Web2025::Plugin::GetUserMeta"); $app->plugin("PAUSE::Web2025::Plugin::ServePauseDoc"); - $app->plugin("PAUSE::Web2025::Plugin::FixAction"); $app->plugin("PAUSE::Web2025::Plugin::WrapAction"); $app->plugin("PAUSE::Web2025::Plugin::EditUtils"); $app->plugin("PAUSE::Web2025::Plugin::Delegate"); diff --git a/lib/pause_2025/PAUSE/Web2025/Plugin/FixAction.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/FixAction.pm deleted file mode 100644 index a29a7bcc0..000000000 --- a/lib/pause_2025/PAUSE/Web2025/Plugin/FixAction.pm +++ /dev/null @@ -1,70 +0,0 @@ -package PAUSE::Web2025::Plugin::FixAction; - -use Mojo::Base "Mojolicious::Plugin"; -use HTTP::Status qw/:constants/; - -# Set hook to convert old ACTION params to router paths -sub register { - my ($self, $app, $conf) = @_; - - $app->hook(before_dispatch => \&_fix); -} - -sub _fix { - my $c = shift; - - _fixup($c); # does what fixup handler did - return if $c->res->is_finished; - - my $action = $c->req->param("ACTION"); - - # Ignore if there's no ACTION or ACTION overrides root - return if !$action or $action eq "root"; - my $path = $c->req->url->path; - $c->req->url->path("$path/$action"); - $c->stash(".pause")->{Action} = $action; -} - - - -=comment - -All Location below /pause share this FixupHandler. All we want to -achieve is that these mappings are in effect: - - /pause redir=> /pause/query CASE 1 - /pause/ trans=> /pause/query CASE 2 - /pause/query OK CASE 3 - /pause/authenquery OK CASE 3 - -I have the suspicion that this would be easier with a completely -different approach, but as it works, I do not investigate further now. -=cut - -sub _fixup { - my $c = shift; - my $req = $c->req; - - my $uri = $req->env->{REQUEST_URI}; - my $location = '/pause'; # $r->location; - - # warn "uri[$uri]location[$location] (Question was, does location ever match /query/?)"; - if ($uri eq $location or $uri eq "$location/") { - - # CASE 1/2 - - my $redir = $req->url->base; - my $is_ssl = $req->headers->header("X-pause-is-SSL") || 0; - if ($is_ssl) { - $redir->scheme("https"); - } - $redir->path("$location/query"); - $c->res->code(HTTP_MOVED_PERMANENTLY); - $c->res->headers->header("Location",$redir); - # warn "redir[$redir]"; - return $c->res->finish; - } - return unless $uri eq "$location/"; -} - -1; From e9ceb9b98e9d3cbc248bd5c469b2ea40c12c8ee7 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 16:48:47 +0900 Subject: [PATCH 16/51] Set $pause->{Action} to param('ACTION') Now that FixAction is removed, we should set the Action somewhere --- lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm | 2 ++ 1 file changed, 2 insertions(+) diff --git a/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm index ba35d2030..8883afd3d 100644 --- a/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm @@ -17,6 +17,8 @@ sub _before_dispatch { $c->stash(".pause" => {}) unless $c->stash(".pause"); + $c->stash(".pause")->{Action} = $c->req->param('ACTION'); + _is_ssl($c); _retrieve_user($c); _set_allowed_actions($c); From 1108b0e9fe6c5d89f67e24899b611284eeff4bce Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 16:50:50 +0900 Subject: [PATCH 17/51] Modify the link to the home --- lib/pause_2025/templates/layouts/layout.html.ep | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/pause_2025/templates/layouts/layout.html.ep b/lib/pause_2025/templates/layouts/layout.html.ep index a60e196a9..8d4109058 100644 --- a/lib/pause_2025/templates/layouts/layout.html.ep +++ b/lib/pause_2025/templates/layouts/layout.html.ep @@ -19,7 +19,7 @@
-

PAUSE Logo +

PAUSE Logo The [Perl programming] Authors Upload Server

From 0988a653a82a1a1522925c41c5d22964b5215c5a Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 16:52:26 +0900 Subject: [PATCH 18/51] Stop adding ACTION hidden field as we can find the action from the path_info --- lib/pause_2025/templates/layouts/layout.html.ep | 3 --- 1 file changed, 3 deletions(-) diff --git a/lib/pause_2025/templates/layouts/layout.html.ep b/lib/pause_2025/templates/layouts/layout.html.ep index 8d4109058..97afe8263 100644 --- a/lib/pause_2025/templates/layouts/layout.html.ep +++ b/lib/pause_2025/templates/layouts/layout.html.ep @@ -79,9 +79,6 @@ Please be careful not to disturb the database operation. Expect failures everywh

[ATTN: Form going to post to <%= $me %>]

% }
enctype="<%= $enctype %>" <% } %>method="<%= $method %>"> - % if (!$action_conf->{method}) { - - % }
% if (my $verb = $action_conf->{verb} and !$action_conf->{has_title}) {

<%= $verb %>

From 358182f0b47cc29871fbe593a52e46ad686b1f31 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 17:45:43 +0900 Subject: [PATCH 19/51] Add configuration entries for login/logout/mfa --- lib/pause_2025/PAUSE/Web2025/Config.pm | 41 ++++++++++++++++++++++++-- 1 file changed, 38 insertions(+), 3 deletions(-) diff --git a/lib/pause_2025/PAUSE/Web2025/Config.pm b/lib/pause_2025/PAUSE/Web2025/Config.pm index 19fb6e4d4..f4dd794c1 100644 --- a/lib/pause_2025/PAUSE/Web2025/Config.pm +++ b/lib/pause_2025/PAUSE/Web2025/Config.pm @@ -4,6 +4,20 @@ use Mojo::Base -base; use PAUSE; our %Actions = ( + # ROOT + login => { + x_mojo_to => "root#login", + verb => "Login", + priv => "root", + method => "POST", + x_csrf_protection => 1, + x_form => { + pause_id => {form_type => "text_field"}, + password => {form_type => "password_field"}, + SUBMIT => {form_type => "submit_button"}, + }, + }, + # PUBLIC request_id => { x_mojo_to => "public-request_id#request", @@ -456,11 +470,32 @@ our %Actions = ( pause99_edit_cred_sub => {form_type => "submit_button"}, }, }, - pause_logout => { - x_mojo_to => "user#pause_logout", - verb => "About Logging Out", + mfa => { + x_mojo_to => "user-mfa#edit", + verb => "Multifactor Auth", + priv => "user", + cat => "User/06Account/03", + desc => "Multifactor Authentication.", + method => 'POST', + x_csrf_protection => 1, + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + pause99_mfa_code => {form_type => "text_field"}, + pause99_mfa_reset => {form_type => "hidden_field"}, + pause99_mfa_sub => {form_type => "submit_button"}, + }, + }, + logout => { + x_mojo_to => "root#logout", + verb => "Log Out", + method => 'POST', priv => "user", cat => "User/06Account/04", + x_csrf_protection => 1, + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + pause99_logout_sub => {form_type => "submit_button"}, + }, }, # ADMIN+mlrep+modlistmaint From e8be0d7f508631f28335d5cafe7a5a1206239247 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 17:46:43 +0900 Subject: [PATCH 20/51] Modify router parameters It's easier just to use action names as paths, but I feed it better to prepend group names to make it clear which action belongs to which group. ->name() is added to help $c->url_for() return the correct path. --- lib/pause_2025/PAUSE/Web2025.pm | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/lib/pause_2025/PAUSE/Web2025.pm b/lib/pause_2025/PAUSE/Web2025.pm index 16a68bac3..d188f323a 100644 --- a/lib/pause_2025/PAUSE/Web2025.pm +++ b/lib/pause_2025/PAUSE/Web2025.pm @@ -51,36 +51,43 @@ sub startup { my $r = $app->routes->under("/")->to("root#check"); # Public Menu - my $public = $r->under("/query"); + my $public = $r->under("/"); $public->any("/")->to("root#index"); for my $group ($app->pause->config->public_groups) { for my $name ($app->pause->config->action_names_for($group)) { my $action = $app->pause->config->action($name); for my $method (qw/get post/) { - my $route = $public->$method("/$name"); + my $route = $public->$method("/$group/$name"); $route->with_csrf_protection if $method eq "post" and $action->{x_csrf_protection}; - $route->to($action->{x_mojo_to}); + $route->to($action->{x_mojo_to}, ACTION => $name)->name($name); } } } # change_passwd is public when it is used for password recovery my $action = $app->pause->config->action('change_passwd'); for my $method (qw/get post/) { - my $route = $public->$method("/change_passwd"); + my $route = $public->$method("/public/change_passwd"); $route->with_csrf_protection if $method eq "post" and $action->{x_csrf_protection}; - $route->to($action->{x_mojo_to}); + $route->to($action->{x_mojo_to}, ACTION => 'change_passwd')->name('change_passwd'); + } + + # login + for my $method (qw/get post/) { + my $route = $public->$method("/login"); + $route->with_csrf_protection if $method eq "post" and $action->{x_csrf_protection}; + $route->to("root#login", ACTION => 'login'); } # Private/User Menu - my $private = $r->under("/authenquery")->to("root#auth"); + my $private = $r->under("/")->to("root#auth"); $private->any("/")->to("root#index"); for my $group ($app->pause->config->all_groups) { for my $name ($app->pause->config->action_names_for($group)) { my $action = $app->pause->config->action($name); for my $method (qw/get post/) { - my $route = $private->$method("/$name"); + my $route = $private->$method("/$group/$name"); $route->with_csrf_protection if $method eq "post" and $action->{x_csrf_protection}; - $route->to($action->{x_mojo_to}); + $route->to($action->{x_mojo_to}, ACTION => $name)->name($name); } } } From 12ce7015ddcceed8172ed6861da33dbe0c431768 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 18:00:24 +0900 Subject: [PATCH 21/51] Add the login action to the Root controller Almost all the login code is taken from ::Middleware::Auth::Basic::authentication. Instead of setting REMOTE_USER, we use Mojolicious's session to keep the user's id (for now; eventually it should be stored in the database). --- .../PAUSE/Web2025/Controller/Root.pm | 93 +++++++++++++++++++ 1 file changed, 93 insertions(+) diff --git a/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm b/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm index 76edba46b..32dede075 100644 --- a/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm +++ b/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm @@ -47,4 +47,97 @@ sub auth { return 1; } +sub login { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + + # already logged in + if ($pause->{User}{userid}) { + $c->redirect_to('/'); + return; + } + + if (uc $req->method eq 'POST') { + my $user_sent = $req->param('pause_id'); + my $sent_pw = $req->param('password'); + + my $attr = { + data_source => $PAUSE::Config->{AUTHEN_DATA_SOURCE_NAME}, + username => $PAUSE::Config->{AUTHEN_DATA_SOURCE_USER}, + password => $PAUSE::Config->{AUTHEN_DATA_SOURCE_PW}, + pwd_table => $PAUSE::Config->{AUTHEN_USER_TABLE}, + uid_field => $PAUSE::Config->{AUTHEN_USER_FLD}, + pwd_field => $PAUSE::Config->{AUTHEN_PASSWORD_FLD}, + }; + + my $dbh; + warn "DEBUG: attr.data_source[$attr->{data_source}]"; + unless ($dbh = DBI->connect($attr->{data_source}, + $attr->{username}, + $attr->{password})) { + Log::Dispatch::Config->instance->log(level => 'error', message => " db connect error with $attr->{data_source} "); + return $c->reply->exception(500); + } + + # generate statement + my $user_record; + my @try_user = $user_sent; + push @try_user, uc $user_sent if $user_sent ne uc $user_sent; + my %session; + + my $statement = qq{SELECT * FROM $attr->{pwd_table} + WHERE $attr->{uid_field}=?}; + # prepare statement + my $sth; + unless ($sth = $dbh->prepare($statement)) { + Log::Dispatch::Config->instance->log(level => 'error', message => "can not prepare statement: $DBI::errstr"); + $sth->finish; + $dbh->disconnect; + return $c->reply->exception(500); + } + for my $user (@try_user){ + unless ($sth->execute($user)) { + Log::Dispatch::Config->instance->log(level => 'error', message => " can not execute statement: $DBI::errstr"); + $sth->finish; + $dbh->disconnect; + return $c->reply->exception(500); + } + + if ($sth->rows == 1){ + $user_record = $mgr->fetchrow($sth, "fetchrow_hashref"); + $session{user} = $user; + } + } + $sth->finish; + + # delete not to be carried around + my $crypt_pw = delete $user_record->{$attr->{pwd_field}}; + if ($crypt_pw) { + if (PAUSE::Crypt::password_verify($sent_pw, $crypt_pw)) { + PAUSE::Crypt::maybe_upgrade_stored_hash({ + password => $sent_pw, + old_hash => $crypt_pw, + dbh => $dbh, + username => $user_record->{user}, + }); + $dbh->do + ("UPDATE usertable SET lastvisit=NOW() where user=?", + +{}, + $user_record->{user}, + ); + $dbh->disconnect; + $c->session(\%session); + return $c->redirect_to('/'); + } else { + warn sprintf "failed login: user[%s]uri[%s]auth_required[%d]", + $user_record->{user}, $req->url->path, 401; + } + } + $dbh->disconnect; + } + $pause->{Action} = 'login'; +} + 1; From b4bb0d2eec16bbcfc472709d48223e5357ce78d8 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 18:08:52 +0900 Subject: [PATCH 22/51] Verify one time password if usertable.mfa is true We can't use mfa_secret32 to decide if the user uses MFA or not, because mfa_secret32 needs to be stored in the database as soon as the user first visit the MFA page; otherwise Auth::GoogleAuth generates a different secret32 when the user posts the authentication code (and thus the verification fails). --- lib/pause_2025/PAUSE/Web2025/Context.pm | 12 +++++++ .../PAUSE/Web2025/Controller/Root.pm | 32 +++++++++++++++++++ 2 files changed, 44 insertions(+) diff --git a/lib/pause_2025/PAUSE/Web2025/Context.pm b/lib/pause_2025/PAUSE/Web2025/Context.pm index c443351a5..f692bb0bc 100644 --- a/lib/pause_2025/PAUSE/Web2025/Context.pm +++ b/lib/pause_2025/PAUSE/Web2025/Context.pm @@ -10,6 +10,7 @@ use Email::MIME; use Data::Dumper; use PAUSE::Web2025::Config; use PAUSE::Web2025::Exception; +use Auth::GoogleAuth; our $VERSION = "1072"; @@ -40,6 +41,17 @@ sub version { $version; } +sub authenticator_for { + my ($self, $user) = @_; + my $cpan_alias = lc($user->{userid}) . '@cpan.org'; + my $secret32 = $user->{mfa_secret32}; + return Auth::GoogleAuth->new({ + secret32 => $secret32, + issuer => $PAUSE::Config->{MFA_ISSUER} || 'PAUSE', + key_id => $cpan_alias, + }); +} + sub hostname { my $self = shift; $PAUSE::Config->{SERVER_NAME} || Sys::Hostname::hostname(); diff --git a/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm b/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm index 32dede075..f5bfe89b4 100644 --- a/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm +++ b/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm @@ -114,6 +114,13 @@ sub login { # delete not to be carried around my $crypt_pw = delete $user_record->{$attr->{pwd_field}}; + if ($user_record->{mfa}) { + if (!_verify_otp($c, $user_record)) { + $pause->{mfa} = 1 unless $req->param('otp'); + $c->render; + return; + } + } if ($crypt_pw) { if (PAUSE::Crypt::password_verify($sent_pw, $crypt_pw)) { PAUSE::Crypt::maybe_upgrade_stored_hash({ @@ -137,7 +144,32 @@ sub login { } $dbh->disconnect; } + delete $pause->{mfa}; $pause->{Action} = 'login'; } +sub _verify_otp { + my ($c, $u) = @_; + my $pause = $c->stash(".pause"); + my $otp = $c->req->param('otp') or return; + if ($otp =~ /\A[0-9]{6}\z/) { + return 1 if $c->app->pause->authenticator_for($u)->verify($otp); + } elsif ($otp =~ /\A[a-z0-9]{5}\-[a-z0-9]{5}\z/) { # maybe one of the recovery codes? + require PAUSE::Crypt; + my $pause = $c->stash(".pause"); + my @recovery_codes = split / /, $u->{mfa_recovery_codes} // ''; + for my $code (@recovery_codes) { + if (PAUSE::Crypt::password_verify($otp, $code)) { + my $new_codes = join ' ', grep { $_ ne $code } @recovery_codes; + my $dbh = $c->app->pause->authen_connect; + my $tbl = $PAUSE::Config->{AUTHEN_USER_TABLE}; + my $sql = "UPDATE $tbl SET mfa_recovery_codes = ?, changed = ?, changedby = ? WHERE user = ?"; + $dbh->do($sql, undef, $new_codes, time, $u->{userid}, $u->{userid}) + or push @{$pause->{ERROR}}, sprintf(qq{Could not enter the data into the database: %s.},$dbh->errstr); + return 1; + } + } + } +} + 1; From 6d945e368a9af556e1ad565c2b7390832bd7a19c Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 18:13:12 +0900 Subject: [PATCH 23/51] Add a template to login --- lib/pause_2025/templates/root/login.html.ep | 24 +++++++++++++++++++++ 1 file changed, 24 insertions(+) create mode 100644 lib/pause_2025/templates/root/login.html.ep diff --git a/lib/pause_2025/templates/root/login.html.ep b/lib/pause_2025/templates/root/login.html.ep new file mode 100644 index 000000000..d56f0a12a --- /dev/null +++ b/lib/pause_2025/templates/root/login.html.ep @@ -0,0 +1,24 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; +% my $mgr = $c->app->pause; + +% if (!$pause->{mfa}) { +

PAUSE ID: <%= text_field "pause_id", size => 15, maxlength => 9 =%>

+

Password: <%= password_field "password", size => 15 =%>

+

+% } else { +

Authentication code

+%= text_field 'otp', autocomplete => 'off'; + +% for my $name (@{ $c->req->params->names }) { + % for my $value (@{ $c->req->every_param($name) }) { + % next if $name eq 'ACTION'; + % next if $name eq 'otp'; + %= hidden_field $name => $value; + % } +% } + +%= submit_button 'verify'; +% } +%= csrf_field + From 68fc61973bdc8de04e86b2156c567fd794ddf92b Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 18:15:01 +0900 Subject: [PATCH 24/51] Add the logout Root action and the template for it Right now we only use the Mojo's session, we just need to clear the session. Eventually we'll also need to remove a session table entry. --- lib/pause_2025/PAUSE/Web2025/Controller/Root.pm | 13 +++++++++++++ lib/pause_2025/templates/root/logout.html.ep | 7 +++++++ 2 files changed, 20 insertions(+) create mode 100644 lib/pause_2025/templates/root/logout.html.ep diff --git a/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm b/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm index f5bfe89b4..c239dd3e6 100644 --- a/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm +++ b/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm @@ -172,4 +172,17 @@ sub _verify_otp { } } +sub logout { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + + if (uc $req->method eq 'POST') { + my $user_id = $pause->{User}{userid}; + $c->session(expires => 1); + $c->redirect_to('/'); + } +} + 1; diff --git a/lib/pause_2025/templates/root/logout.html.ep b/lib/pause_2025/templates/root/logout.html.ep new file mode 100644 index 000000000..3edc773fb --- /dev/null +++ b/lib/pause_2025/templates/root/logout.html.ep @@ -0,0 +1,7 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; +% my $mgr = $c->app->pause; + +

+%= csrf_field + From c94001c30669cc36d7aae36f4920438f875a99fd Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 18:18:28 +0900 Subject: [PATCH 25/51] Fix app's secret The secret should be the same for all the workers. It is used to encrypt Mojo's cookie(-based session). --- lib/pause_2025/PAUSE/Web2025.pm | 2 +- lib/pause_2025/PAUSE/Web2025/Context.pm | 5 +++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/lib/pause_2025/PAUSE/Web2025.pm b/lib/pause_2025/PAUSE/Web2025.pm index d188f323a..02d768e0f 100644 --- a/lib/pause_2025/PAUSE/Web2025.pm +++ b/lib/pause_2025/PAUSE/Web2025.pm @@ -23,7 +23,7 @@ sub startup { $app->hook(around_dispatch => \&_log); # Set random secrets to keep mojo session secure - $app->secrets([sha1_hex($$.time)]); + $app->secrets([sha1_hex($app->pause->secret)]); # Fix template path for now unshift @{$app->renderer->paths}, $app->home->rel_file("lib/pause_2025/templates"); diff --git a/lib/pause_2025/PAUSE/Web2025/Context.pm b/lib/pause_2025/PAUSE/Web2025/Context.pm index f692bb0bc..7a0d2175e 100644 --- a/lib/pause_2025/PAUSE/Web2025/Context.pm +++ b/lib/pause_2025/PAUSE/Web2025/Context.pm @@ -41,6 +41,11 @@ sub version { $version; } +sub secret { + my $self = shift; + $PAUSE::Config->{WEB_SECRET} || $self->hostname; +} + sub authenticator_for { my ($self, $user) = @_; my $cpan_alias = lc($user->{userid}) . '@cpan.org'; From 6e33f91161bfc7061688b83bebb52d5b32e95111 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 18:30:45 +0900 Subject: [PATCH 26/51] Make sure the action (taken from the path_info) is allowed for the user (taken from a session) is_allowed_action is factored out from ConfigPerRequest::_set_allowed_actions --- lib/pause_2025/PAUSE/Web2025/Controller/Root.pm | 6 +++++- .../PAUSE/Web2025/Plugin/ConfigPerRequest.pm | 17 ++++++++++++++++- 2 files changed, 21 insertions(+), 2 deletions(-) diff --git a/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm b/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm index c239dd3e6..6fbc8fe7e 100644 --- a/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm +++ b/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm @@ -6,13 +6,17 @@ sub check { my $c = shift; if ($c->pause_is_closed) { - my $user = $c->req->env->{REMOTE_USER}; + my $session = $c->session || {}; + my $user = $session->{user}; if ($user and $user eq "ANDK") { } else { $c->render("closed"); return; } } + if (my $action = $c->match->stack->[-1]{ACTION}) { + return unless $c->is_allowed_action($action); + } return 1; } diff --git a/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm index 8883afd3d..fd4b449a5 100644 --- a/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm @@ -10,6 +10,7 @@ sub register { my ($self, $app, $conf) = @_; $app->hook(before_dispatch => \&_before_dispatch); $app->helper(need_form_data => \&_need_form_data); + $app->helper(is_allowed_action => \&_is_allowed_action); } sub _before_dispatch { @@ -249,8 +250,21 @@ parameter ABRA=$param, but the database doesn't know about this token.", HTTP_ST $pause->{allow_action} = [ sort { $a cmp $b } keys %allow_action ]; # warn "allowaction[@{$pause->{allow_action}}]"; # warn "allowsubmit[@allow_submit]"; + $pause->{allow_submit} = \@allow_submit; +} + +sub _is_allowed_action { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + + my %allow_action = map {$_ => undef} @{ $pause->{allow_action} }; + my @allow_submit = @{ $pause->{allow_submit} }; + + my $userid = $pause->{User}{userid}; - $param = $req->param("ACTION"); + my $param = shift || $req->param("ACTION"); # warn "ACTION-param[$param]req[$req]"; if ($param) { if (exists $allow_action{$param}) { @@ -323,6 +337,7 @@ parameter ABRA=$param, but the database doesn't know about this token.", HTTP_ST warn "$userid tried disallowed action: $action"; die PAUSE::Web2025::Exception->new(ERROR => "Forbidden", HTTP_STATUS => 403); } + return 1; # warn "action[$action]"; } From b6577fed7bb042b82dd6878caa1b8fefbd0e1c32 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 18:32:57 +0900 Subject: [PATCH 27/51] Redirect to /login if the action requires authentication and the session does not have a user --- lib/pause_2025/PAUSE/Web2025/Controller/Root.pm | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm b/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm index 6fbc8fe7e..192e74286 100644 --- a/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm +++ b/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm @@ -48,6 +48,12 @@ sub index { sub auth { my $c = shift; + my $session = $c->session || {}; + + unless ($session->{user}) { + $c->redirect_to('/login'); + return; + } return 1; } From 992b6ce08ae8b575b1a733d7e5530bc68f606d46 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 18:35:04 +0900 Subject: [PATCH 28/51] Retrieve a user from the user id stored in the session --- lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm index fd4b449a5..ef8ec66ff 100644 --- a/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm @@ -50,8 +50,9 @@ sub _retrieve_user { my $c = shift; my $pause = $c->stash(".pause"); my $mgr = $c->app->pause; + my $session = $c->session || {}; - my $user = $c->req->env->{REMOTE_USER} or return; + my $user = $session->{user} or return; # This is a database application with nearly all users having write access # Write access means expiration any moment From 4850dfd6bcfcd029536c0244b895a7ee6ffa45ad Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 18:35:43 +0900 Subject: [PATCH 29/51] Retrieve user secrets while retrieving a user user_secrets was used to be retrieved when a user is authenticated via Basic Auth, but we don't use it now. Maybe _retrieve_user is the best place to retrieve the secrets. --- lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm index ef8ec66ff..c88b9dcdd 100644 --- a/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm @@ -97,12 +97,13 @@ sub _retrieve_user { $sth->finish; my $dbh2 = $mgr->authen_connect; - $sth = $dbh2->prepare("SELECT secretemail + $sth = $dbh2->prepare("SELECT * 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; + my $user_record = $sth->fetchrow_hashref; + delete $user_record->{$PAUSE::Config->{AUTHEN_PASSWORD_FLD}}; + $pause->{User}{secretemail} = $user_record->{secretemail}; $sth->finish; $sql = qq{SELECT * @@ -134,7 +135,7 @@ sub _retrieve_user { $pause->{IsMailinglistRepresentative} = \%mlrepr; } - $pause->{UserSecrets} = $c->req->env->{"pause.user_secrets"}; + $pause->{UserSecrets} = $user_record; if ( $pause->{UserSecrets}{forcechange} ) { $pause->{Action} = "change_passwd"; # ueberschreiben $c->req->param(ACTION => "change_passwd"); # faelschen From b7f2496d6ce52216fd1265e43df251f68f7dfc77 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 18:39:27 +0900 Subject: [PATCH 30/51] Allow login action --- lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm index c88b9dcdd..7155f685a 100644 --- a/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm @@ -153,6 +153,7 @@ sub _set_allowed_actions { # What is allowed here is allowed to anybody @allow_action{ $mgr->config->action_names_for('public') } = (); + $allow_action{login} = undef; @allow_submit = ( "request_id", From d0474ba91bfe855f22cb3c0848e3d2f245dee818 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 18:41:39 +0900 Subject: [PATCH 31/51] Retrieve the user from the $c->session --- lib/pause_2025/templates/_user_menu.html.ep | 5 +++-- lib/pause_2025/templates/_user_status.html.ep | 3 ++- lib/pause_2025/templates/layouts/layout.html.ep | 3 ++- 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/lib/pause_2025/templates/_user_menu.html.ep b/lib/pause_2025/templates/_user_menu.html.ep index be296d4fe..6331d6f14 100644 --- a/lib/pause_2025/templates/_user_menu.html.ep +++ b/lib/pause_2025/templates/_user_menu.html.ep @@ -1,7 +1,8 @@ % my $pause = stash(".pause") || {}; % my $user = $pause->{User} || {}; % my $user_groups = $pause->{UserGroups} || {}; -% my $is_public = $c->req->url->path =~ /^query/ ? 1 : 0; +% my $session = $c->session || {}; +% my $logged_in = $session->{user} ? 1 : 0; % my @offer_groups = app->pause->config->public_groups; % $pause->{Action} ||= "menu"; % if (%$user) { @@ -12,7 +13,7 @@ % }
% } elsif ($pause->{closed}) { - % my $user = $c->req->env->{REMOTE_USER}; + % my $user = $session->{user};

Hi <%= $user %>, you see the site now but it is closed for maintainance. From 15d0876da465df3b9ca3aa2e6ecdc3f1960464ae Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 22:04:02 +0900 Subject: [PATCH 32/51] Redirect to /login if active_user_record fails to retrieve a user from a session maybe because of session timeout --- lib/pause_2025/PAUSE/Web2025/Exception.pm | 2 +- .../PAUSE/Web2025/Plugin/GetActiveUserRecord.pm | 8 ++------ lib/pause_2025/PAUSE/Web2025/Plugin/WrapAction.pm | 6 +++++- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/lib/pause_2025/PAUSE/Web2025/Exception.pm b/lib/pause_2025/PAUSE/Web2025/Exception.pm index 6d967e81e..8562e7939 100644 --- a/lib/pause_2025/PAUSE/Web2025/Exception.pm +++ b/lib/pause_2025/PAUSE/Web2025/Exception.pm @@ -2,7 +2,7 @@ package PAUSE::Web2025::Exception; use Mojo::Base -base; use overload - '""' => sub {$_[0]->{ERROR} ? $_[0]->{ERROR} : $_[0]->{HTTP_STATUS} ? $_[0]->{HTTP_STATUS} : ""}, + '""' => sub {$_[0]->{ERROR} ? $_[0]->{ERROR} : $_[0]->{HTTP_STATUS} ? $_[0]->{HTTP_STATUS} : $_[0]->{NEEDS_LOGIN} ? $_[0]->{NEEDS_LOGIN} : ""}, ; diff --git a/lib/pause_2025/PAUSE/Web2025/Plugin/GetActiveUserRecord.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/GetActiveUserRecord.pm index 6134704b8..dfce1555c 100644 --- a/lib/pause_2025/PAUSE/Web2025/Plugin/GetActiveUserRecord.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/GetActiveUserRecord.pm @@ -64,7 +64,7 @@ sub _get { $sth1->rows, $sth1->rows, )); - die PAUSE::Web2025::Exception->new(ERROR => "Unidentified error happened, please write to the PAUSE admin at $PAUSE::Config->{ADMIN} and help him identifying what's going on. Thanks!"); + die PAUSE::Web2025::Exception->new(NEEDS_LOGIN => 1); } my $hiddenuser_h1 = $mgr->fetchrow($sth1, "fetchrow_hashref"); @@ -154,11 +154,7 @@ sub _get { my $dbh1 = $mgr->connect; my $sth1 = $dbh1->prepare("SELECT * FROM users WHERE userid=?"); $sth1->execute($pause->{User}{userid}); - die PAUSE::Web2025::Exception - ->new(ERROR => - "Unidentified error happened, please write to the PAUSE admin - at $PAUSE::Config->{ADMIN} and help them identify what's going on. Thanks!") - unless $sth1->rows; + die PAUSE::Web2025::Exception->new(NEEDS_LOGIN => 1) unless $sth1->rows; $pause->{User} = $mgr->fetchrow($sth1, "fetchrow_hashref"); $sth1->finish; diff --git a/lib/pause_2025/PAUSE/Web2025/Plugin/WrapAction.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/WrapAction.pm index d25997b7d..204c28ea2 100644 --- a/lib/pause_2025/PAUSE/Web2025/Plugin/WrapAction.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/WrapAction.pm @@ -21,7 +21,11 @@ sub _wrap { my $res = eval { $next->(); }; if (my $e = $@) { if (UNIVERSAL::isa($e, "PAUSE::Web2025::Exception")) { - if ($e->{ERROR}) { + if ($e->{NEEDS_LOGIN}) { + $c->redirect_to('/login'); + return; + } + elsif ($e->{ERROR}) { $e->{ERROR} = [ $e->{ERROR} ] unless ref $e->{ERROR} eq 'ARRAY'; push @{$pause->{ERROR}}, @{$e->{ERROR}}; require Data::Dumper; From 1c80f17348617ed5db7dbeb3a988ac236f355a6d Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 22:11:58 +0900 Subject: [PATCH 33/51] Add an MFA controller and templates --- .../PAUSE/Web2025/Controller/User/Mfa.pm | 94 +++++++++++++++++++ .../templates/email/user/mfa/edit.email.ep | 19 ++++ .../templates/user/mfa/edit.html.ep | 64 +++++++++++++ 3 files changed, 177 insertions(+) create mode 100644 lib/pause_2025/PAUSE/Web2025/Controller/User/Mfa.pm create mode 100644 lib/pause_2025/templates/email/user/mfa/edit.email.ep create mode 100644 lib/pause_2025/templates/user/mfa/edit.html.ep diff --git a/lib/pause_2025/PAUSE/Web2025/Controller/User/Mfa.pm b/lib/pause_2025/PAUSE/Web2025/Controller/User/Mfa.pm new file mode 100644 index 000000000..351606ffe --- /dev/null +++ b/lib/pause_2025/PAUSE/Web2025/Controller/User/Mfa.pm @@ -0,0 +1,94 @@ +package PAUSE::Web2025::Controller::User::Mfa; + +use Mojo::Base "Mojolicious::Controller"; +use Auth::GoogleAuth; +use PAUSE::Crypt; +use Crypt::URandom qw(urandom); +use Convert::Base32 qw(encode_base32); +use Imager::QRCode qw(plot_qrcode); +use URI; + +sub edit { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + my $u = $c->active_user_record; + + my $auth = $c->app->pause->authenticator_for($u); + $pause->{mfa_qrcode} = _generate_qrcode($auth); + if (!$u->{mfa_secret32}) { + my $dbh = $mgr->authen_connect; + my $tbl = $PAUSE::Config->{AUTHEN_USER_TABLE}; + my $sql = "UPDATE $tbl SET mfa_secret32 = ?, changed = ?, changedby = ? WHERE user = ?"; + $dbh->do($sql, undef, $auth->secret32, time, $pause->{User}{userid}, $u->{userid}) + or push @{$pause->{ERROR}}, sprintf(qq{Could not enter the data into the database: %s.},$dbh->errstr); + } + + if (uc $req->method eq 'POST' and $req->param("pause99_mfa_sub")) { + my $code = $req->param("pause99_mfa_code"); + $req->param("pause99_mfa_code", undef); + if ($code =~ /\A[0-9]{6}\z/ && !$auth->verify($code)) { + $pause->{error}{invalid_code} = 1; + return; + } elsif ($code =~ /\A[a-z0-9]{5}\-[a-z0-9]{5}\z/ && $u->{mfa_recovery_codes} && $req->param("pause99_mfa_reset")) { + my @recovery_codes = split / /, $u->{mfa_recovery_codes} // ''; + if (!grep { PAUSE::Crypt::password_verify($code, $_) } @recovery_codes) { + $pause->{error}{invalid_code} = 1; + return; + } + } + my ($mfa, $secret32, $recovery_codes); + if ($req->param("pause99_mfa_reset")) { + $mfa = 0; + $secret32 = undef; + $recovery_codes = undef; + $c->flash(mfa_disabled => 1); + } else { + $mfa = 1; + $secret32 = $auth->secret32; + $c->flash(mfa_enabled => 1); + my @codes = _generate_recovery_codes(); + $c->flash(recovery_codes => \@codes); + $recovery_codes = join " ", map { PAUSE::Crypt::hash_password($_) } @codes; + } + my $dbh = $mgr->authen_connect; + my $tbl = $PAUSE::Config->{AUTHEN_USER_TABLE}; + my $sql = "UPDATE $tbl SET mfa = ?, mfa_secret32 = ?, mfa_recovery_codes = ?, changed = ?, changedby = ? WHERE user = ?"; + if ($dbh->do($sql, undef, $mfa, $secret32, $recovery_codes, time, $pause->{User}{userid}, $u->{userid})) { + my $mailblurb = $c->render_to_string("email/user/mfa/edit", format => "email"); + my $header = {Subject => "User update for $u->{userid}"}; + my @to = $u->{secretemail}; + $mgr->send_mail_multi(\@to, $header, $mailblurb); + } else { + push @{$pause->{ERROR}}, sprintf(qq{Could not enter the data + into the database: %s.},$dbh->errstr); + } + $c->redirect_to('/user/mfa'); + } +} + +sub _generate_recovery_codes { + my @codes; + for (1 .. 8) { + my $code = encode_base32(urandom(6)); + $code =~ tr/lo/89/; + $code =~ s/^(.{5})/$1-/; + push @codes, $code; + } + @codes; +} + +# using $auth->qr_code directly is handy but insecure +sub _generate_qrcode { + my $auth = shift; + my $otpauth = $auth->qr_code(undef, undef, undef, 1); + my $img = plot_qrcode($otpauth, { casesensitive => 1, size => 4, margin => 4, version => 1, level => 'M' }); + $img->write(data => \my $qr_png, type => 'png') or die "Failed to write image: " . $img->errstr; + my $data = URI->new("data:"); + $data->data($qr_png); + $data->media_type('image/png'); + $data; +} + +1; diff --git a/lib/pause_2025/templates/email/user/mfa/edit.email.ep b/lib/pause_2025/templates/email/user/mfa/edit.email.ep new file mode 100644 index 000000000..454cf824d --- /dev/null +++ b/lib/pause_2025/templates/email/user/mfa/edit.email.ep @@ -0,0 +1,19 @@ +% my $pause = stash(".pause") || {}; +% +%#------------------------------------------------------------------ +% +Record update in the PAUSE users database: + +<%== sprintf "%11s: [%s]", "userid", $pause->{HiddenUser}{userid} %> + +% if ($pause->{mfa_enabled}) { +Multifactor Authentication is enabled. +% } elsif ($pause->{mfa_disabled}) { +Multifactor Authentication is disabled. +% } + +Data were entered by <%== $pause->{User}{userid} %> (<%== $pause->{User}{fullname} %>). +Please check if they are correct. + +Thanks, +The PAUSE Team diff --git a/lib/pause_2025/templates/user/mfa/edit.html.ep b/lib/pause_2025/templates/user/mfa/edit.html.ep new file mode 100644 index 000000000..d6d1fe733 --- /dev/null +++ b/lib/pause_2025/templates/user/mfa/edit.html.ep @@ -0,0 +1,64 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; +% my $cpan_alias = lc($pause->{HiddenUser}{userid}) . '@cpan.org'; + + + +% if (flash('mfa_enabled')) { +

+

Multifactor Authentication is enabled.

+

Recovery codes:

+ +
    +% for my $code (@{ flash('recovery_codes') }) { +
  • <%= $code %> +% } +
+ +

Please write down these codes, as they will not show again.

+
+% } elsif (flash('mfa_disabled')) { +
+

Multifactor Authentication is disabled. Please remove the invalidated entry from your authenticator.

+
+% } + +% if ($pause->{HiddenUser}{mfa}) { +

You have already enabled multifactor authentication.

+% } else { +

Enable Multifactor Authentication for <%= $pause->{HiddenUser}{userid} %> +% if (exists $pause->{UserGroups}{admin}) { + (lastvisit <%= $pause->{HiddenUser}{lastvisit} || "before 2005-12-02" %>) +% } +

+% } + +% if (my $error = $pause->{error}) { +
+ERROR: +% if ($error->{invalid_code}) { +Verification Code is invalid. +% } +
+
+% } +% if (!$pause->{HiddenUser}{mfa}) { +
+

Scan the QR code and submit 6-digit code to enable Multifactor Authentication.

+ +
+% } else { +

If you really need to disable multifactor authentication, please look at your authenticator and submit 6-digit code shown there (or one of the recovery codes you have never used before).

+<%= hidden_field "pause99_mfa_reset" => 1, autocomplete => 'off' %> +% } + +
+

CODE: <%= text_field "pause99_mfa_code" => '', + size => 10, + maxlength => 10, + autocomplete => 'off', +%> +

+
+ +%= csrf_field From ec544d3f5357db2a4f6c6f94bbf9a8c1e8920ca8 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 22:22:29 +0900 Subject: [PATCH 34/51] Remove Auth::Basic middleware --- .../PAUSE/Web2025/Middleware/Auth/Basic.pm | 190 ------------------ 1 file changed, 190 deletions(-) delete mode 100644 lib/pause_2025/PAUSE/Web2025/Middleware/Auth/Basic.pm diff --git a/lib/pause_2025/PAUSE/Web2025/Middleware/Auth/Basic.pm b/lib/pause_2025/PAUSE/Web2025/Middleware/Auth/Basic.pm deleted file mode 100644 index e7d46a565..000000000 --- a/lib/pause_2025/PAUSE/Web2025/Middleware/Auth/Basic.pm +++ /dev/null @@ -1,190 +0,0 @@ -package PAUSE::Web2025::Middleware::Auth::Basic; - -use Mojo::Base "Plack::Middleware"; -use MIME::Base64; -use HTTP::Status qw/:constants/; -use PAUSE (); -use PAUSE::Crypt; -use Plack::Request; -use DBI; -use Carp (); - -has "context"; - -sub call { - my ($self, $env) = @_; - - local $SIG{__WARN__} = sub { - my $message = shift; - chomp $message; - Log::Dispatch::Config->instance->log( - level => 'warn', - message => $message, - ); - }; - - warn "before authentication"; - my $res = eval { $self->authenticate($env) }; - if ($@) { - Log::Dispatch::Config->instance->log( - level => 'error', - message => "AUTH ERROR: $@", - ); - } - - return $res->finalize if ref $res; - return $self->unauthorized($env) unless $res == HTTP_OK; - return $self->app->($env); -} - -sub unauthorized { - my ($self, $env) = @_; - my $body = delete $env->{"pause.auth_error"} || 'Authorization required'; - return [ - 401, - [ 'Content-Type' => 'text/plain', - 'Content-Length' => length $body, - 'WWW-Authenticate' => 'Basic realm="PAUSE"' ], - [ $body ], - ]; -} - - -sub authenticate { - my ($self, $env) = @_; - - my $req = Plack::Request->new($env); - - my $cookie; - my $uri = $req->path || ""; - $uri = "/pause".$uri unless $uri =~ m!/pause/!; # add mount point - my $args = $req->uri->query || ""; - warn "WATCH: uri[$uri]args[$args]"; - if ($cookie = $req->headers->header('Cookie')) { - if ( $cookie =~ /logout/ ) { - warn "WATCH: cookie[$cookie]"; - my $res = $req->new_response(HTTP_UNAUTHORIZED); - $res->cookies->{logout} = { - value => '', - path => $uri, - expires => "Sat, 01-Oct-1974 00:00:00 UTC", - }; - return $res; - } - } - warn "WATCH: uri[$uri]args[$args]"; - if ($args) { - my $logout; - if ( my $logout = $req->query_parameters->get('logout') ) { - warn "WATCH: logout[$logout]"; - if ($logout =~ /^1/) { - my $res = $req->new_response(HTTP_MOVED_PERMANENTLY); - $res->cookies->{logout} = { - value => '', - path => $uri, - expires => "Sat, 01-Oct-2027 00:00:00 UTC", - }; - $res->headers->header("Location",$uri); - return $res; - } elsif ($logout =~ /^2/) { # badname - my $redir = $req->base; - $redir->path($req->uri->path); - $redir->userinfo('baduser:badpass'); - warn "redir[$redir]"; - my $res = $req->new_response(HTTP_MOVED_PERMANENTLY); - $res->headers->header("Location",$redir); - return $res; - } elsif ($logout =~ /^3/) { # cancelnote - return HTTP_UNAUTHORIZED; - } - } - } - - warn "WATCH: uri[$uri]args[$args]"; - my $auth = $env->{HTTP_AUTHORIZATION} or return HTTP_UNAUTHORIZED; - return HTTP_UNAUTHORIZED unless $auth =~ /^Basic (.*)$/i; #decline if not Basic - my $basic = $1; - my($user_sent, $sent_pw) = split /:/, (MIME::Base64::decode($basic) || ":"), 2; - - warn "WATCH: uri[$uri]args[$args]"; - my $attr = { - data_source => $PAUSE::Config->{AUTHEN_DATA_SOURCE_NAME}, - username => $PAUSE::Config->{AUTHEN_DATA_SOURCE_USER}, - password => $PAUSE::Config->{AUTHEN_DATA_SOURCE_PW}, - pwd_table => $PAUSE::Config->{AUTHEN_USER_TABLE}, - uid_field => $PAUSE::Config->{AUTHEN_USER_FLD}, - pwd_field => $PAUSE::Config->{AUTHEN_PASSWORD_FLD}, - }; - - my $dbh; - warn "DEBUG: attr.data_source[$attr->{data_source}]"; - unless ($dbh = DBI->connect($attr->{data_source}, - $attr->{username}, - $attr->{password})) { - Log::Dispatch::Config->instance->log(level => 'error', message => " db connect error with $attr->{data_source} ".$req->path); - my $redir = $req->path; - $redir =~ s/authen//; - delete $env->{REMOTE_USER}; - return $req->new_response(HTTP_INTERNAL_SERVER_ERROR, undef, $redir); - } - - # generate statement - my $user_record; - my @try_user = $user_sent; - push @try_user, uc $user_sent if $user_sent ne uc $user_sent; - - my $statement = qq{SELECT * FROM $attr->{pwd_table} - WHERE $attr->{uid_field}=?}; - # prepare statement - my $sth; - unless ($sth = $dbh->prepare($statement)) { - Log::Dispatch::Config->instance->log(level => 'error', message => "can not prepare statement: $DBI::errstr". $req->path); - $sth->finish; - $dbh->disconnect; - return $req->new_response(HTTP_INTERNAL_SERVER_ERROR); - } - for my $user (@try_user){ - unless ($sth->execute($user)) { - Log::Dispatch::Config->instance->log(level => 'error', message => " can not execute statement: $DBI::errstr" . $req->path); - $sth->finish; - $dbh->disconnect; - return $req->new_response(HTTP_INTERNAL_SERVER_ERROR); - } - - if ($sth->rows == 1){ - $user_record = $self->context->fetchrow($sth, "fetchrow_hashref"); - $env->{REMOTE_USER} = $user; - last; - } - } - $sth->finish; - - # delete not to be carried around - my $crypt_pw = delete $user_record->{$attr->{pwd_field}}; - if ($crypt_pw) { - if (PAUSE::Crypt::password_verify($sent_pw, $crypt_pw)) { - PAUSE::Crypt::maybe_upgrade_stored_hash({ - password => $sent_pw, - old_hash => $crypt_pw, - dbh => $dbh, - username => $user_record->{user}, - }); - $env->{"pause.user_secrets"} = $user_record; - $dbh->do - ("UPDATE usertable SET lastvisit=NOW() where user=?", - +{}, - $user_record->{user}, - ); - $dbh->disconnect; - return HTTP_OK; - } else { - warn sprintf "failed login: user[%s]uri[%s]auth_required[%d]", - $user_record->{user}, $req->path, HTTP_UNAUTHORIZED; - } - } - - $dbh->disconnect; - return HTTP_UNAUTHORIZED; -} - -1; From 79f7146d8dbf6e53fba144a3e283bbffb2991548 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sat, 26 Apr 2025 22:32:35 +0900 Subject: [PATCH 35/51] Add one off schema change file --- one-off-utils/schemachange-2025.sql | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 one-off-utils/schemachange-2025.sql diff --git a/one-off-utils/schemachange-2025.sql b/one-off-utils/schemachange-2025.sql new file mode 100644 index 000000000..b981d9722 --- /dev/null +++ b/one-off-utils/schemachange-2025.sql @@ -0,0 +1,3 @@ +ALTER TABLE usertable ADD COLUMN mfa tinyint(1) DEFAULT 0; +ALTER TABLE usertable ADD COLUMN mfa_secret32 varchar(16); +ALTER TABLE usertable ADD COLUMN mfa_recovery_codes text; From fa8e73ace69634b6b46a335acb7c3dc6f796e5a6 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Thu, 1 May 2025 22:50:39 +0900 Subject: [PATCH 36/51] Fix tail_logfile url in an email --- lib/pause_2025/PAUSE/Web2025/Controller/User/Uri.pm | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/lib/pause_2025/PAUSE/Web2025/Controller/User/Uri.pm b/lib/pause_2025/PAUSE/Web2025/Controller/User/Uri.pm index 48e0e3bed..f24d00186 100644 --- a/lib/pause_2025/PAUSE/Web2025/Controller/User/Uri.pm +++ b/lib/pause_2025/PAUSE/Web2025/Controller/User/Uri.pm @@ -250,8 +250,7 @@ try again or report errors to my_full_url(ACTION => 'tail_logfile')->query(pause99_tail_logfile_1 => 5000); $pause->{usrdir} = $usrdir; $pause->{tailurl} = $tailurl; From c868a23fe032eea82b21d854a077e10c95160bdd Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Thu, 1 May 2025 22:51:42 +0900 Subject: [PATCH 37/51] my_full_url should also respect the ACTION parameter as it is usually used in an email or side menu --- lib/pause_2025/PAUSE/Web2025/Plugin/MyURL.pm | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/lib/pause_2025/PAUSE/Web2025/Plugin/MyURL.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/MyURL.pm index 98bbfa355..b9409f6fe 100644 --- a/lib/pause_2025/PAUSE/Web2025/Plugin/MyURL.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/MyURL.pm @@ -21,10 +21,13 @@ sub register { }); $app->helper(my_full_url => sub { my $c = shift; + my %param = ref $_[0] ? () : @_; my $url = $c->req->url->clone->to_abs; $url->query->pairs([]); - my $path_query = $c->my_url(@_); - $url->path_query($path_query); + my $action = $param{ACTION} ? delete $param{ACTION} : ''; + my $path = $c->url_for($action); + $url->path_query($path); + $url->query(ref $_[0] ? $_[0] : %param); $url->query->remove('ABRA'); $url; }); From a84ce80db9cf899ef2d87c86f460af1b2d895fbe Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Thu, 1 May 2025 22:56:14 +0900 Subject: [PATCH 38/51] Add a "public" endpoint to prevent the "check" endpoint from being called twice --- lib/pause_2025/PAUSE/Web2025.pm | 2 +- lib/pause_2025/PAUSE/Web2025/Controller/Root.pm | 2 ++ 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/lib/pause_2025/PAUSE/Web2025.pm b/lib/pause_2025/PAUSE/Web2025.pm index 02d768e0f..4a2bc7def 100644 --- a/lib/pause_2025/PAUSE/Web2025.pm +++ b/lib/pause_2025/PAUSE/Web2025.pm @@ -51,7 +51,7 @@ sub startup { my $r = $app->routes->under("/")->to("root#check"); # Public Menu - my $public = $r->under("/"); + my $public = $r->under("/")->to("root#public"); $public->any("/")->to("root#index"); for my $group ($app->pause->config->public_groups) { for my $name ($app->pause->config->action_names_for($group)) { diff --git a/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm b/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm index 192e74286..763c6ac66 100644 --- a/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm +++ b/lib/pause_2025/PAUSE/Web2025/Controller/Root.pm @@ -21,6 +21,8 @@ sub check { return 1; } +sub public { return 1 } + sub index { my $c = shift; my $pause = $c->stash(".pause"); From b880f666ecba3f1741b0780455f968c5bc650fcd Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Thu, 1 May 2025 22:57:32 +0900 Subject: [PATCH 39/51] Reintroduce PAUSE::Web2025::Plugin::WithCSRFProtection (until I release a new version of Mojolicious::Plugin::WithCSRFProtection) --- lib/pause_2025/PAUSE/Web2025.pm | 3 +- .../Web2025/Plugin/WithCSRFProtection.pm | 180 ++++++++++++++++++ 2 files changed, 182 insertions(+), 1 deletion(-) create mode 100644 lib/pause_2025/PAUSE/Web2025/Plugin/WithCSRFProtection.pm diff --git a/lib/pause_2025/PAUSE/Web2025.pm b/lib/pause_2025/PAUSE/Web2025.pm index 4a2bc7def..c0ca3cd78 100644 --- a/lib/pause_2025/PAUSE/Web2025.pm +++ b/lib/pause_2025/PAUSE/Web2025.pm @@ -32,7 +32,8 @@ sub startup { unshift @{$app->static->paths}, $app->home->rel_file("htdocs"); # Load plugins to modify path/set stash values/provide helper methods - $app->plugin("WithCSRFProtection"); +# $app->plugin("WithCSRFProtection"); + $app->plugin("PAUSE::Web2025::Plugin::WithCSRFProtection"); $app->plugin("PAUSE::Web2025::Plugin::ConfigPerRequest"); $app->plugin("PAUSE::Web2025::Plugin::IsPauseClosed"); $app->plugin("PAUSE::Web2025::Plugin::GetActiveUserRecord"); diff --git a/lib/pause_2025/PAUSE/Web2025/Plugin/WithCSRFProtection.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/WithCSRFProtection.pm new file mode 100644 index 000000000..4d85b4557 --- /dev/null +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/WithCSRFProtection.pm @@ -0,0 +1,180 @@ +package PAUSE::Web2025::Plugin::WithCSRFProtection; + +# patched version of Mojolicious::Plugin::WithCSRFProtection +# cf. https://github.com/charsbar/Mojolicious-Plugin-WithCSRFProtection/pull/2 + +# ABSTRACT: Mojolicious plugin providing CSRF protection at the routing level + +use Mojo::Base 'Mojolicious::Plugin'; + +our $VERSION = '1.00_01'; + +sub register { + my ( $self, $app ) = @_; + + my $routes = $app->routes; + + $app->helper( + 'reply.bad_csrf' => sub { + my ($c) = @_; + $c->res->code(403); + $c->render_maybe('bad_csrf') + or $c->render( text => 'Failed CSRF check' ); + return; + } + ); + + $routes->add_condition( + with_csrf_protection => sub { + my ( $route, $c ) = @_; + + my $csrf = $c->req->headers->header('X-CSRF-Token') + || $c->param('csrf_token'); + + unless ( $csrf && $csrf eq $c->csrf_token ) { + $c->reply->bad_csrf unless $c->stash->{'mojo.finished'}; + return; + } + + return 1; + } + ); + + $routes->add_shortcut( + with_csrf_protection => sub { + my ($route) = @_; + return $route->requires( with_csrf_protection => 1 ); + } + ); + + return; +} + +1; + +__END__ + +=head1 SYNOPSIS + + # in a lite application + post '/some-url' => ( with_csrf_protection => 1 ) => sub { ... }; + + # in a full application + $app->routes->post('/some-url') + ->with_csrf_protection + ->to(...); + +=head1 DESCRIPTION + +This Mojolicious plugin provides a routing condition (called +C) and routing shortcut to add that condition (also called +C) that can be used to protect against cross site request +forgery. + +Adding the condition to the route checks a valid CSRF token was passed, either +in the C HTTP header or in the C parameter. + +Failing the CSRF check causes a 403 error and the C template to be +rendered, or if no such template is found a simple error string to be +output. This behavior is unlike most conditions that can be applied to +Mojolicious routes that normally just cause the route matching to fail and +alternative subsequent routes to be evaluated, but immediately returning an +error response makes sense for a failed CSRF check. The actual error rendering +is performed by the C helper that this plugin installs, and if +you want different error output you should override that helper. + +=head1 EXAMPLES + +=head2 A Mojolicious::Lite application + +Here's a simple Mojolicious application that I can run on my desktop computer +that creates a very simple web interface to adding things to do to my +C. + +Because I don't want anyone web page on the internet to be able to tell my +browser to add whatever that web page feels like to my todo list, I add CSRF +protection with the C<< with_csrf_protection => 1 >> condition to the POST. + + #!/usr/bin/perl + + use Mojolicious::Lite; + + plugin 'WithCSRFProtection'; + plugin 'TagHelpers'; + + get '/' => sub {} => 'index'; + + post '/note' => (with_csrf_protection => 1) => sub { + my ($c) = @_; + open my $fh, '>>', $ENV{HOME}.'/todo.txt' or die "Can't open todo: $!"; + print $fh $c->param('item'), "\n"; + }; + + app->start; + + __DATA__ + @@ index.html.ep + + + %= form_for note => begin + %= text_field 'item' + %= csrf_field + %= submit_button + % end + + + + @@ note.html.ep + + + Okay, I wrote that down! + + + +The template for the index makes use of the C tag helper to +render a hidden input field containing the current csrf_token: + + + + + + + + + + +However if a bad agent causes your browser to try POSTing to the form without +the CSRF token (or for that matter the corresponding session cookie), you just +get the standard CSRF protection error message: + + shell$ curl -X POST -F 'item=transfer money to bad guys' http://127.0.0.1:3000/note + Failed CSRF check + +=head2 A Mojolicious AJAX application + +In this example we have a hypothetical Mojolicious application that uses jQuery +to POST some JSON to the server. To provide CSRF protection we make use of the +C header. + +It's possible to configure jQuery to add additional headers on each request: + + + +Once you've done this it's further possible wherever you define your routes to +require this CSRF header (or one of the C parameters) with the +C shortcut (which just applies the C +condition) + + sub startup { + my ($self) = @_; + $self->routes + ->post('/launch-nukes') + ->with_csrf_protection + ->to('nuke#launch'); + ... + } From 8357835250e53a8c95ba2ddc5c96599ed80b1379 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Thu, 1 May 2025 23:01:55 +0900 Subject: [PATCH 40/51] Copy all the tests for pause_2017 under t/pause_2025 --- t/pause_2025/00_load.t | 20 + t/pause_2025/action/add_uri.t | 296 +++++++++++++ t/pause_2025/action/add_user.t | 276 ++++++++++++ t/pause_2025/action/change_passwd.t | 227 ++++++++++ t/pause_2025/action/delete_files.t | 244 ++++++++++ t/pause_2025/action/edit_cred.t | 65 +++ t/pause_2025/action/edit_ml.t | 18 + t/pause_2025/action/edit_uris.t | 45 ++ t/pause_2025/action/email_for_admin.t | 18 + t/pause_2025/action/giveup_comaint.t | 112 +++++ t/pause_2025/action/giveup_dist_comaint.t | 109 +++++ t/pause_2025/action/mailpw.t | 175 ++++++++ t/pause_2025/action/make_comaint.t | 170 +++++++ t/pause_2025/action/make_dist_comaint.t | 165 +++++++ t/pause_2025/action/manage_id_requests.t | 18 + t/pause_2025/action/move_dist_primary.t | 161 +++++++ t/pause_2025/action/move_primary.t | 168 +++++++ t/pause_2025/action/pause_04about.t | 18 + t/pause_2025/action/pause_04imprint.t | 18 + t/pause_2025/action/pause_05news.t | 18 + t/pause_2025/action/pause_06history.t | 18 + t/pause_2025/action/pause_logout.t | 18 + t/pause_2025/action/pause_namingmodules.t | 18 + t/pause_2025/action/pause_operating_model.t | 18 + t/pause_2025/action/pause_privacy_policy.t | 18 + t/pause_2025/action/peek_dist_perms.t | 172 ++++++++ t/pause_2025/action/peek_perms.t | 240 ++++++++++ t/pause_2025/action/reindex.t | 47 ++ t/pause_2025/action/remove_comaint.t | 172 ++++++++ t/pause_2025/action/remove_dist_comaint.t | 166 +++++++ t/pause_2025/action/remove_dist_primary.t | 134 ++++++ t/pause_2025/action/remove_primary.t | 138 ++++++ t/pause_2025/action/request_id.t | 273 ++++++++++++ t/pause_2025/action/reset_version.t | 48 ++ t/pause_2025/action/select_ml_action.t | 49 +++ t/pause_2025/action/select_user.t | 18 + t/pause_2025/action/share_perms.t | 18 + t/pause_2025/action/show_files.t | 18 + t/pause_2025/action/show_ml_repr.t | 18 + t/pause_2025/action/tail_logfile.t | 43 ++ t/pause_2025/action/who_admin.t | 44 ++ t/pause_2025/action/who_pumpkin.t | 44 ++ t/pause_2025/auth.t | 62 +++ t/pause_2025/lib/Test/PAUSE/MySQL.pm | 242 ++++++++++ t/pause_2025/lib/Test/PAUSE/Web.pm | 464 ++++++++++++++++++++ t/pause_2025/logout.t | 44 ++ 46 files changed, 4885 insertions(+) create mode 100644 t/pause_2025/00_load.t create mode 100644 t/pause_2025/action/add_uri.t create mode 100644 t/pause_2025/action/add_user.t create mode 100644 t/pause_2025/action/change_passwd.t create mode 100644 t/pause_2025/action/delete_files.t create mode 100644 t/pause_2025/action/edit_cred.t create mode 100644 t/pause_2025/action/edit_ml.t create mode 100644 t/pause_2025/action/edit_uris.t create mode 100644 t/pause_2025/action/email_for_admin.t create mode 100644 t/pause_2025/action/giveup_comaint.t create mode 100644 t/pause_2025/action/giveup_dist_comaint.t create mode 100644 t/pause_2025/action/mailpw.t create mode 100644 t/pause_2025/action/make_comaint.t create mode 100644 t/pause_2025/action/make_dist_comaint.t create mode 100644 t/pause_2025/action/manage_id_requests.t create mode 100644 t/pause_2025/action/move_dist_primary.t create mode 100644 t/pause_2025/action/move_primary.t create mode 100644 t/pause_2025/action/pause_04about.t create mode 100644 t/pause_2025/action/pause_04imprint.t create mode 100644 t/pause_2025/action/pause_05news.t create mode 100644 t/pause_2025/action/pause_06history.t create mode 100644 t/pause_2025/action/pause_logout.t create mode 100644 t/pause_2025/action/pause_namingmodules.t create mode 100644 t/pause_2025/action/pause_operating_model.t create mode 100644 t/pause_2025/action/pause_privacy_policy.t create mode 100644 t/pause_2025/action/peek_dist_perms.t create mode 100644 t/pause_2025/action/peek_perms.t create mode 100644 t/pause_2025/action/reindex.t create mode 100644 t/pause_2025/action/remove_comaint.t create mode 100644 t/pause_2025/action/remove_dist_comaint.t create mode 100644 t/pause_2025/action/remove_dist_primary.t create mode 100644 t/pause_2025/action/remove_primary.t create mode 100644 t/pause_2025/action/request_id.t create mode 100644 t/pause_2025/action/reset_version.t create mode 100644 t/pause_2025/action/select_ml_action.t create mode 100644 t/pause_2025/action/select_user.t create mode 100644 t/pause_2025/action/share_perms.t create mode 100644 t/pause_2025/action/show_files.t create mode 100644 t/pause_2025/action/show_ml_repr.t create mode 100644 t/pause_2025/action/tail_logfile.t create mode 100644 t/pause_2025/action/who_admin.t create mode 100644 t/pause_2025/action/who_pumpkin.t create mode 100644 t/pause_2025/auth.t create mode 100644 t/pause_2025/lib/Test/PAUSE/MySQL.pm create mode 100644 t/pause_2025/lib/Test/PAUSE/Web.pm create mode 100644 t/pause_2025/logout.t diff --git a/t/pause_2025/00_load.t b/t/pause_2025/00_load.t new file mode 100644 index 000000000..1b32717c9 --- /dev/null +++ b/t/pause_2025/00_load.t @@ -0,0 +1,20 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/lib"; +use Test::PAUSE::Web; +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_2017"); + $path =~ s|\.pm$|| or return; + $path =~ s|/|::|g; + use_ok($path); +}, no_chdir => 1}, "$Test::PAUSE::Web::AppRoot/lib/pause_2017/PAUSE"); + +done_testing; + diff --git a/t/pause_2025/action/add_uri.t b/t/pause_2025/action/add_uri.t new file mode 100644 index 000000000..5d1c22f66 --- /dev/null +++ b/t/pause_2025/action/add_uri.t @@ -0,0 +1,296 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use File::Path qw/rmtree mkpath/; +use File::Spec; +use Mojo::File qw/path/; +use utf8; + +my $http_upload = { + pause99_add_uri_httpupload => ["$Test::PAUSE::Web::AppRoot/htdocs/index.html", "index.html"], + SUBMIT_pause99_add_uri_httpupload => 1, +}; + +my $uri_upload = { + pause99_add_uri_uri => "file://".File::Spec->rel2abs(__FILE__), + SUBMIT_pause99_add_uri_uri => 1, +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=add_uri"); + # note $t->content; + } +}; + +subtest 'get: user with subdirs' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $user_home = $PAUSE::Config->{MLROOT}."/".PAUSE::user2dir($user); + my $subdir = path("$user_home/test"); + $subdir->make_path; + $subdir->child("stuff.txt")->spew("Foo"); + + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=add_uri"); + $t->text_is('select[name="pause99_add_uri_subdirscrl"] option[value="."]', "."); # default + $t->text_is('select[name="pause99_add_uri_subdirscrl"] option[value="test"]', "test"); + # note $t->content; + } +}; + +subtest 'post: basic' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$http_upload; + my $file = $PAUSE::Config->{INCOMING_LOC}."/".$form{pause99_add_uri_httpupload}[1]; + ok !-f $file, "file to upload does not exist"; + + $t->mod_dbh->do('TRUNCATE uris'); + $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + # note $t->content; + + ok -f $file, "uploaded file exists"; + unlink $file; + + my $rows = $t->mod_db->select('uris', ['*'], { + userid => $user, + uri => $form{pause99_add_uri_httpupload}[1], + }); + is @$rows => 1; + } +}; + +subtest 'post: under a new subdir' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$http_upload; + $form{pause99_add_uri_subdirtext} = "new_dir"; + + my $file = $PAUSE::Config->{INCOMING_LOC}."/".$form{pause99_add_uri_httpupload}[1]; + ok !-f $file, "file to upload does not exist"; + + $t->mod_dbh->do('TRUNCATE uris'); + $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + # note $t->content; + + ok -f $file, "uploaded file exists"; + unlink $file; + + my $rows = $t->mod_db->select('uris', ['*'], { + userid => $user, + uri => $form{pause99_add_uri_httpupload}[1], + }); + is @$rows => 1; + like $rows->[0]{uriid} => qr!/new_dir/!, "uriid contains /new_dir/"; + } +}; + +subtest 'post: under a Perl6 subdir' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$http_upload; + $form{pause99_add_uri_subdirscrl} = "Perl6"; + + my $user_home = $PAUSE::Config->{MLROOT}."/".PAUSE::user2dir($user); + my $subdir = path("$user_home/Perl6"); + $subdir->make_path; + $subdir->child("stuff.txt")->spew("Foo"); + + my $file = $PAUSE::Config->{INCOMING_LOC}."/".$form{pause99_add_uri_httpupload}[1]; + ok !-f $file, "file to upload does not exist"; + + $t->mod_dbh->do('TRUNCATE uris'); + $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + # note $t->content; + + ok -f $file, "uploaded file exists"; + unlink $file; + + my $rows = $t->mod_db->select('uris', ['*'], { + userid => $user, + uri => $form{pause99_add_uri_httpupload}[1], + }); + is @$rows => 1; + like $rows->[0]{uriid} => qr!/Perl6/!, "uriid contains /Perl6/"; + ok $rows->[0]{is_perl6}; + } +}; + +subtest 'post: empty' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$http_upload; + $form{pause99_add_uri_httpupload} = [undef, 'index.html']; + + $t->mod_dbh->do('TRUNCATE uris'); + $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + # note $t->content; + + my $rows = $t->mod_db->select('uris', ['*'], { + userid => $user, + uri => $form{pause99_add_uri_httpupload}[1], + }); + is @$rows => 0; + } +}; + +subtest 'post: renamed' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$http_upload; + $form{pause99_add_uri_httpupload} = ["$Test::PAUSE::Web::AppRoot/htdocs/index.html", 'html/index.html']; + my $file = $PAUSE::Config->{INCOMING_LOC}."/index.html"; + ok !-f $file, "file to upload does not exist"; + + $t->mod_dbh->do('TRUNCATE uris'); + $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + # note $t->content; + + # renamed file exists + ok -f $file, "uploaded file exists"; + unlink $file; + + my $rows = $t->mod_db->select('uris', ['*'], { + userid => $user, + uri => "index.html", + }); + is @$rows => 1; + } +}; + +subtest 'post: uri' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$uri_upload; + + $t->mod_dbh->do('TRUNCATE uris'); + $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + # note $t->content; + + my $rows = $t->mod_db->select('uris', ['*'], { + userid => $user, + uri => $form{pause99_add_uri_uri}, + }); + is @$rows => 1; + } +}; + +subtest 'post: CHECKSUMS' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$http_upload; + $form{pause99_add_uri_httpupload} = ["$Test::PAUSE::Web::AppRoot/htdocs/index.html", "CHECKSUMS"], + + $t->mod_dbh->do('TRUNCATE uris'); + $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + $t->text_like('.error_message' => qr/Files with the name CHECKSUMS cannot be/); + # note $t->content; + + my $rows = $t->mod_db->select('uris', ['*'], { + userid => $user, + uri => $form{pause99_add_uri_httpupload}[1], + }); + is @$rows => 0; + } +}; + +subtest 'post: allow overwrite' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$http_upload; + my $file = $PAUSE::Config->{INCOMING_LOC}."/".$form{pause99_add_uri_httpupload}[1]; + ok !-f $file, "file to upload does not exists"; + + $t->mod_dbh->do('TRUNCATE uris'); + for (0 .. 1) { + $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + # note $t->content; + + # uploaded file exists + ok -f $file, "uploaded file exists"; + unlink $file; + } + + my $rows = $t->mod_db->select('uris', ['*'], { + userid => $user, + uri => $form{pause99_add_uri_httpupload}[1], + }); + is @$rows => 1; + } +}; + +subtest 'post: duplicate' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$http_upload; + $form{pause99_add_uri_httpupload} = ["$Test::PAUSE::Web::AppRoot/htdocs/index.html", "index.tar.gz"], + my $file = $PAUSE::Config->{INCOMING_LOC}."/".$form{pause99_add_uri_httpupload}[1]; + ok !-f $file, "file to upload does not exist"; + + $t->mod_dbh->do('TRUNCATE uris'); + $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + # note $t->content; + + ok -f $file, "uploaded file exists"; + unlink $file; + + my $rows = $t->mod_db->select('uris', ['*'], { + userid => $user, + uri => $form{pause99_add_uri_httpupload}[1], + }); + is @$rows => 1; + + my $res = $t->post("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + is $res->code => 409; + # note $t->content; + + ok -f $file, "uploaded file exists"; + unlink $file; + + $rows = $t->mod_db->select('uris', ['*'], { + userid => $user, + uri => $form{pause99_add_uri_httpupload}[1], + }); + is @$rows => 1; + } +}; + +subtest 'post: to the site top, as various CPAN uploaders do/did' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$http_upload; + my $file = $PAUSE::Config->{INCOMING_LOC}."/".$form{pause99_add_uri_httpupload}[1]; + ok !-f $file, "file to upload does not exist"; + + $t->mod_dbh->do('TRUNCATE uris'); + $t->post_ok("$path", \%form, "Content-Type" => "form-data"); + # note $t->content; + + ok -f $file, "uploaded file exists"; + unlink $file; + + my $rows = $t->mod_db->select('uris', ['*'], { + userid => $user, + uri => $form{pause99_add_uri_httpupload}[1], + }); + is @$rows => 1; + } +}; + +done_testing; diff --git a/t/pause_2025/action/add_user.t b/t/pause_2025/action/add_user.t new file mode 100644 index 000000000..0912d03a3 --- /dev/null +++ b/t/pause_2025/action/add_user.t @@ -0,0 +1,276 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +my $new_user = { + SUBMIT_pause99_add_user_Definitely => 1, + pause99_add_user_userid => "NEWUSER", + pause99_add_user_fullname => "new user", + pause99_add_user_email => "new_user\@localhost.localdomain", + pause99_add_user_homepage => "http://home.page", +}; + +my $new_mailing_list = { + SUBMIT_pause99_add_user_Definitely => 1, + pause99_add_user_userid => "MAILLIST", + pause99_add_user_fullname => "Mailing List", + pause99_add_user_email => "ml\@localhost.localdomain", + pause99_add_user_subscribe => "how to subscribe", +}; + +my $default = { + HIDDENNAME => "TESTUSER", + ACTIONREQ => "edit_ml", + pause99_select_ml_action_sub => 1, +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=add_user"); + # note $t->content; + } +}; + +subtest 'post: ordinary user' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->reset_fixture; + $t->post_ok("$path?ACTION=add_user", $new_user); + # note $t->content; + + # new user exists + my $rows = $t->mod_db->select('users', ['*'], { + userid => $new_user->{pause99_add_user_userid}, + }); + is @$rows => 1; + for my $key (qw/userid homepage fullname/) { + is $rows->[0]{$key} => $new_user->{"pause99_add_user_$key"}, "$key is stored correctly"; + } + is $rows->[0]{email} => 'CENSORED'; # email in the user table is always CENSORED + + # email tests; censored email shouldn't be disclosed to admins + my @deliveries = $t->deliveries; + my @welcome_emails = grep { $_->header('Subject') =~ /Welcome/ } @deliveries; + is @welcome_emails => 2; + my ($welcome_for_user) = grep { $_->header('To') =~ /new_user/ } @welcome_emails; + like $welcome_for_user->body => qr/email:\s+new_user\@localhost/; + + my ($welcome_for_admins) = grep { $_->header('To') =~ /admin/ } @welcome_emails; + unlike $welcome_for_admins->body => qr/email:\s+new_user\@localhost/; + like $welcome_for_admins->body => qr/email:\s+CENSORED/; + } +}; + +subtest 'post: user with an accent in their name' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->reset_fixture; + $t->post_ok("$path?ACTION=add_user", { + %$new_user, + pause99_add_user_fullname => "T\xc3\xa9st Name", + }); + # note $t->content; + + # new user exists + my $rows = $t->mod_db->select('users', ['*'], { + userid => $new_user->{pause99_add_user_userid}, + }); + is @$rows => 1; + SKIP: { + skip "FIXME: seems not so stable; probably needs more explicit configuration", 1; + is $rows->[0]{fullname} => "T\xc3\xa9st Name"; + } + } +}; + +subtest 'post: soundex' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %copied_user = %$new_user; + $copied_user{pause99_add_user_fullname} = 'new user'; + $copied_user{SUBMIT_pause99_add_user_Soundex} = 1; + delete $copied_user{SUBMIT_pause99_add_user_Definitely}; + + $t->reset_fixture; + $t->post_ok("$path?ACTION=add_user", { + %copied_user, + }); + # note $t->content; + + # new user exists + my $rows = $t->mod_db->select('users', ['*'], { + userid => $new_user->{pause99_add_user_userid}, + }); + is @$rows => 1; + } +}; + +subtest 'post: soundex error: similar name' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %copied_user = %$new_user; + $copied_user{pause99_add_user_fullname} = 'new nome'; + $copied_user{SUBMIT_pause99_add_user_Soundex} = 1; + delete $copied_user{SUBMIT_pause99_add_user_Definitely}; + + $t->reset_fixture; + $t->post_ok("$path?ACTION=add_user", { + %copied_user, + }); + $t->text_like('h3', qr/Not submitting NEWUSER, maybe we have a duplicate/); + # note $t->content; + + # new user does not exist + my $rows = $t->mod_db->select('users', ['*'], { + userid => $new_user->{pause99_add_user_userid}, + }); + is @$rows => 0; + } +}; + +subtest 'post: metaphone' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %copied_user = %$new_user; + $copied_user{pause99_add_user_fullname} = 'new user'; + $copied_user{SUBMIT_pause99_add_user_Metaphone} = 1; + delete $copied_user{SUBMIT_pause99_add_user_Definitely}; + + $t->reset_fixture; + $t->post_ok("$path?ACTION=add_user", { + %copied_user, + }); + # note $t->content; + + # new user exists + my $rows = $t->mod_db->select('users', ['*'], { + userid => $new_user->{pause99_add_user_userid}, + }); + is @$rows => 1; + } +}; + +subtest 'post: metaphone error: similar name' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %copied_user = %$new_user; + $copied_user{pause99_add_user_fullname} = 'new nome'; + $copied_user{SUBMIT_pause99_add_user_Metaphone} = 1; + delete $copied_user{SUBMIT_pause99_add_user_Definitely}; + + $t->reset_fixture; + $t->post_ok("$path?ACTION=add_user", { + %copied_user, + }); + $t->text_like('h3', qr/Not submitting NEWUSER, maybe we have a duplicate/); + # note $t->content; + + # new user does not exist + my $rows = $t->mod_db->select('users', ['*'], { + userid => $new_user->{pause99_add_user_userid}, + }); + is @$rows => 0; + } +}; + +subtest 'post: metaphone error: completely duplicated' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %copied_user = %$new_user; + $copied_user{SUBMIT_pause99_add_user_Metaphone} = 1; + delete $copied_user{SUBMIT_pause99_add_user_Definitely}; + + $t->reset_fixture; + $t->post_ok("$path?ACTION=add_user", { + %copied_user, + }); + + # new user exists + my $rows = $t->mod_db->select('users', ['*'], { + userid => $new_user->{pause99_add_user_userid}, + }); + is @$rows => 1; + + $t->post_ok("$path?ACTION=add_user", { + %copied_user, + }); + $t->text_like('h3', qr/Not submitting NEWUSER, maybe we have a duplicate/); + # note $t->content; + } +}; + +subtest 'post: mailing list' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->reset_fixture; + $t->post_ok("$path?ACTION=add_user", $new_mailing_list); + # note $t->content; + + # new mailing list exists + my $rows = $t->mod_db->select('maillists', ['*'], { + maillistid => $new_mailing_list->{pause99_add_user_userid}, + }); + is @$rows => 1; + + # new user also exists + $rows = $t->mod_db->select('users', ['*'], { + userid => $new_mailing_list->{pause99_add_user_userid}, + }); + is @$rows => 1; + } +}; + +subtest 'get: retrieve a stored session' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %requested_user; + for my $key (keys %$new_user) { + next if $key =~ /SUBMIT/; + my $new_key = $key =~ s/add_user/request_id/r; + $requested_user{$new_key} = $new_user->{$key}; + } + $requested_user{pause99_request_id_rationale} = 'Rational to request PAUSE ID'; + $requested_user{SUBMIT_pause99_request_id_sub} = 1; + + $t->reset_fixture; + $t->post_ok("$path?ACTION=request_id", \%requested_user); + my ($email) = map {$_->body} $t->deliveries; + my ($userid) = $email =~ m!https://.+?/pause/authenquery.+?USERID=([^&\s]+)!; + like $userid => qr/\A\d+_\w+\z/; + $t->clear_deliveries; + + $t->get_ok("$path?ACTION=add_user&USERID=$userid"); + # note $t->content; + + for my $key (keys %$new_user) { + next if $key =~ /SUBMIT/; + is $t->dom->at("input[name=$key]")->attr('value') => $new_user->{$key}, "$key is set correctly"; + } + } +}; + +done_testing; diff --git a/t/pause_2025/action/change_passwd.t b/t/pause_2025/action/change_passwd.t new file mode 100644 index 000000000..c447fb14c --- /dev/null +++ b/t/pause_2025/action/change_passwd.t @@ -0,0 +1,227 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use Time::Piece; +use utf8; + +my $default = { + pause99_change_passwd_pw1 => "new_pass", + pause99_change_passwd_pw2 => "new_pass", + pause99_change_passwd_sub => 1, +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=change_passwd"); + # note $t->content; + } +}; + +subtest 'get: public without ABRA' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + next if $user; # public only + my $t = Test::PAUSE::Web->new(user => $user); + $t->authen_dbh->do('TRUNCATE abrakadabra'); + my $res = $t->get("$path?ACTION=change_passwd"); + is $res->code => 403; + # note $t->content; + } +}; + +subtest 'get: public with ABRA' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + next if $user; # public only + my $t = Test::PAUSE::Web->new(user => $user); + + my $chuser = 'TESTUSER'; + my $chpass = 'testpassword'; + $t->authen_dbh->do('TRUNCATE abrakadabra'); + ok $t->authen_db->insert('abrakadabra', { + user => $chuser, + chpasswd => $chpass, + expires => Time::Piece->new(time + 3600)->strftime('%Y-%m-%d %H:%M:%S'), + }); + + $t->get_ok("$path?ACTION=change_passwd&ABRA=$chuser.$chpass"); + # note $t->content; + + # No links should keep ABRA (71a745d) + my @links = map {$_->attr('href')} $t->dom->at('a'); + ok !grep {$_ =~ /ABRA=/} @links; + } +}; + +subtest 'post: basic' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my %form = %$default; + my $t = Test::PAUSE::Web->new(user => $user); + my $res = $t->post("$path?ACTION=change_passwd", \%form); + ok !$res->is_success && $res->code == 403, "Forbidden"; + like $res->content => qr/Failed CSRF check/; + # note $t->content; + } +}; + +subtest 'post_with_token: basic' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my %form = %$default; + my $t = Test::PAUSE::Web->new(user => $user); + $t->post_with_token_ok("$path?ACTION=change_passwd", \%form) + ->text_like("p.password_stored", qr/New password stored/); + is $t->deliveries => 1, "one delivery for admin"; + # note $t->content; + } +}; + +subtest 'post_with_token: user with CENSORED email' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + $user = "TESTCNSRD" if $user eq "TESTUSER"; + + my %form = %$default; + my $t = Test::PAUSE::Web->new(user => $user); + $t->post_with_token_ok("$path?ACTION=change_passwd", \%form) + ->text_like("p.password_stored", qr/New password stored/); + my @deliveries = $t->deliveries; + is @deliveries => 1, "one delivery for admin"; + my $email = $deliveries[0]->as_string; + unlike $email => qr/CENSORED/; + like $email => qr/testcnsrd\@localhost/; + note $email; + # note $t->content; + } +}; + +subtest 'post_with_token: public without ABRA' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + next if $user; # public only + my $t = Test::PAUSE::Web->new(user => $user); + $t->authen_dbh->do('TRUNCATE abrakadabra'); + + my %form = %$default; + my $res = $t->post_with_token("$path?ACTION=change_passwd", \%form); + is $res->code => 403; + # note $t->content; + } +}; + +subtest 'post_with_token: public with ABRA' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + next if $user; # public only + my $t = Test::PAUSE::Web->new(user => $user); + + my $chuser = 'TESTUSER'; + my $chpass = 'testpassword'; + $t->authen_dbh->do('TRUNCATE abrakadabra'); + ok $t->authen_db->insert('abrakadabra', { + user => $chuser, + chpasswd => $chpass, + expires => Time::Piece->new(time + 3600)->strftime('%Y-%m-%d %H:%M:%S'), + }); + + my %form = %$default; + $t->post_with_token_ok("$path?ACTION=change_passwd&ABRA=$chuser.$chpass", \%form); + $t->text_like("p.password_stored", qr/New password stored/); + # note $t->content; + + # No links should keep ABRA (71a745d) + my @links = map {$_->attr('href')} $t->dom->at('a'); + ok !grep {$_ =~ /ABRA=/} @links; + + # Used ABRA is gone (8234a6a) + my $res = $t->post_with_token("$path?ACTION=change_passwd&ABRA=$chuser.$chpass", \%form); + ok !$res->is_success; + is $res->code => 401; + } +}; + +subtest 'post_with_token: public with incorrect ABRA' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + next if $user; # public only + my $t = Test::PAUSE::Web->new(user => $user); + + my $chuser = 'TESTUSER'; + my $chpass = 'testpassword'; + $t->authen_dbh->do('TRUNCATE abrakadabra'); + ok $t->authen_db->insert('abrakadabra', { + user => $chuser, + chpasswd => $chpass, + expires => Time::Piece->new(time + 3600)->strftime('%Y-%m-%d %H:%M:%S'), + }); + + my %form = %$default; + my $res = $t->post_with_token("$path?ACTION=change_passwd&ABRA=$chuser.wrong$chpass", \%form); + is $res->code => 401; + # note $t->content; + } +}; + +subtest 'post_with_token: passwords mismatch' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_change_passwd_pw2 => "wrong_pass", + ); + $t->post_with_token_ok("$path?ACTION=change_passwd", \%form) + ->text_is("h2", "Error") + ->text_like("p.error_message", qr/The two passwords didn't match./); + ok !$t->deliveries, "no delivery for admin"; + # note $t->content; + } +}; + +subtest 'post_with_token: only one password' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_change_passwd_pw2 => undef, + ); + $t->post_with_token_ok("$path?ACTION=change_passwd", \%form) + ->text_is("h2", "Error") + ->text_like("p.error_message", qr/You need to fill in the same password in both fields./); + ok !$t->deliveries, "no delivery for admin"; + # note $t->content; + } +}; + +subtest 'post_with_token: no password' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_change_passwd_pw1 => undef, + pause99_change_passwd_pw2 => undef, + ); + $t->post_with_token_ok("$path?ACTION=change_passwd", \%form) + ->text_is("h2", "Error") + ->text_like("p.error_message", qr/Please fill in the form with passwords./); + ok !$t->deliveries, "no delivery for admin"; + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/delete_files.t b/t/pause_2025/action/delete_files.t new file mode 100644 index 000000000..07ea06525 --- /dev/null +++ b/t/pause_2025/action/delete_files.t @@ -0,0 +1,244 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +my $default_for_add_uri = { + pause99_add_uri_httpupload => [Test::PAUSE::Web->file_to_upload], + SUBMIT_pause99_add_uri_httpupload => 1, +}; + +my $default = { + pause99_delete_files_FILE => ["Hash-RenameKey-0.02.tar.gz"], +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=delete_files"); + # note $t->content; + } +}; + +subtest 'post: basic' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->mod_dbh->do("TRUNCATE uris"); + $t->mod_dbh->do("TRUNCATE deletes"); + $t->remove_authors_dir($user); + + # prepare distribution + $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + + $t->copy_to_authors_dir($user, scalar Test::PAUSE::Web->file_to_upload); + + # delete + my %form = %$default; + $form{SUBMIT_pause99_delete_files_delete} = 1; + $t->post_ok("$path?ACTION=delete_files", \%form); + # note $t->content; + + my @deliveries = $t->deliveries; + is @deliveries => 2; + my ($mail_body) = map {$_->body} @deliveries; + like $mail_body => qr/ACTION=delete_files/; + + my $rows = $t->mod_db->select('deletes', ['*']); + is @$rows => 1; + like $rows->[0]{deleteid} => qr!/$form{pause99_delete_files_FILE}[0]$!; + + # undelete + delete $form{SUBMIT_pause99_delete_files_delete}; + $form{SUBMIT_pause99_delete_files_undelete} = 1; + $t->post_ok("$path?ACTION=delete_files", \%form); + # note $t->content; + + ok $rows = $t->mod_db->select('deletes', ['*']); + ok !@$rows; + } +}; + +subtest 'post: absolute path' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->mod_dbh->do("TRUNCATE uris"); + $t->mod_dbh->do("TRUNCATE deletes"); + $t->remove_authors_dir($user); + + # prepare distribution + $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + + my $copied = $t->copy_to_authors_dir($user, scalar Test::PAUSE::Web->file_to_upload); + ok(File::Spec->file_name_is_absolute($copied)); + + # delete + my %form = ( + pause99_delete_files_FILE => [$copied], + SUBMIT_pause99_delete_files_delete => 1 + ); + $t->post_ok("$path?ACTION=delete_files", \%form); + # note $t->content; + + my @deliveries = $t->deliveries; + is @deliveries => 2; + my ($mail_body) = map {$_->body} @deliveries; + like $mail_body => qr/WARNING: illegal filename/; + + my $rows = $t->mod_db->select('deletes', ['*']); + ok !@$rows; + } +}; + +subtest 'post: file not found' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->mod_dbh->do("TRUNCATE uris"); + $t->mod_dbh->do("TRUNCATE deletes"); + $t->remove_authors_dir($user); + + # prepare distribution + $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + + my $copied = $t->copy_to_authors_dir($user, scalar Test::PAUSE::Web->file_to_upload); + + # delete + my %form = ( + pause99_delete_files_FILE => ['Something-Else-0.02.tar.gz'], + SUBMIT_pause99_delete_files_delete => 1 + ); + $t->post_ok("$path?ACTION=delete_files", \%form); + # note $t->content; + + my @deliveries = $t->deliveries; + is @deliveries => 2; + my ($mail_body) = map {$_->body} @deliveries; + like $mail_body => qr/WARNING: file not found/; + + my $rows = $t->mod_db->select('deletes', ['*']); + ok !@$rows; + } +}; + +subtest 'post: CHECKSUMS' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->mod_dbh->do("TRUNCATE uris"); + $t->mod_dbh->do("TRUNCATE deletes"); + $t->remove_authors_dir($user); + + # prepare distribution + $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + + my $copied = $t->copy_to_authors_dir($user, scalar Test::PAUSE::Web->file_to_upload); + $t->save_to_authors_dir($user, "CHECKSUMS", "CHECKSUMS"); + + # delete + my %form = ( + pause99_delete_files_FILE => ['CHECKSUMS'], + SUBMIT_pause99_delete_files_delete => 1 + ); + $t->post_ok("$path?ACTION=delete_files", \%form); + # note $t->content; + + my @deliveries = $t->deliveries; + is @deliveries => 2; + my ($mail_body) = map {$_->body} @deliveries; + like $mail_body => qr/WARNING: CHECKSUMS not erasable/; + + my $rows = $t->mod_db->select('deletes', ['*']); + ok !@$rows; + } +}; + +subtest 'post: readme' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->mod_dbh->do("TRUNCATE uris"); + $t->mod_dbh->do("TRUNCATE deletes"); + $t->remove_authors_dir($user); + + # prepare distribution + $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + + my $copied = $t->copy_to_authors_dir($user, scalar Test::PAUSE::Web->file_to_upload); + $t->save_to_authors_dir($user, "Hash-RenameKey-0.02.readme", "README"); + + # delete + my %form = %$default; + $form{SUBMIT_pause99_delete_files_delete} = 1; + $t->post_ok("$path?ACTION=delete_files", \%form); + # note $t->content; + + # .readme is deleted when a related tarball is removed + my @deliveries = $t->deliveries; + is @deliveries => 2; + my ($mail_body) = map {$_->body} @deliveries; + like $mail_body => qr/\.readme/; + + my $rows = $t->mod_db->select('deletes', ['*']); + is @$rows => 2; + ok grep {$_->{deleteid} =~ /\.readme$/} @$rows; + } +}; + +subtest 'post: delete by admin using select_user' => sub { + { + my $test = Test::PAUSE::Web->tests_for('user'); + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->mod_dbh->do("TRUNCATE uris"); + $t->mod_dbh->do("TRUNCATE deletes"); + $t->remove_authors_dir($user); + + # prepare distribution + $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + + my $copied = $t->copy_to_authors_dir($user, scalar Test::PAUSE::Web->file_to_upload); + } + { + my $test = Test::PAUSE::Web->tests_for('admin'); + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %action_form = ( + HIDDENNAME => "TESTUSER", + ACTIONREQ => "delete_files", + pause99_select_user_sub => 1, + ); + $t->post_ok("$path?ACTION=select_user", \%action_form); + # note $t->content; + + # delete + my %form = %$default; + $form{SUBMIT_pause99_delete_files_delete} = 1; + $form{HIDDENNAME} = "TESTUSER"; + $t->post_ok("$path?ACTION=delete_files", \%form); + # note $t->content; + + my @deliveries = $t->deliveries; + is @deliveries => 3; # for TESTUSER, TESTADMIN, pause_admin + my ($mail_body) = map {$_->body} @deliveries; + like $mail_body => qr/ACTION=delete_files/; + + my $rows = $t->mod_db->select('deletes', ['*']); + is @$rows => 1; + like $rows->[0]{deleteid} => qr!/$form{pause99_delete_files_FILE}[0]$!; + } +}; + +done_testing; diff --git a/t/pause_2025/action/edit_cred.t b/t/pause_2025/action/edit_cred.t new file mode 100644 index 000000000..507859f8f --- /dev/null +++ b/t/pause_2025/action/edit_cred.t @@ -0,0 +1,65 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +my $default = { + pause99_edit_cred_fullname => "new fullname", + pause99_edit_cred_asciiname => "new ascii name", + pause99_edit_cred_email => "new_email\@localhost.localdomain", + pause99_edit_cred_homepage => "none", + pause99_edit_cred_cpan_mail_alias => "none", + pause99_edit_cred_sub => 1, +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=edit_cred"); + # note $t->content; + } +}; + +subtest 'post: basic' => sub { + plan skip_all => 'SKIP for now'; + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = %$default; + $t->post_ok("$path?ACTION=edit_cred", \%form); + # note $t->content; + } +}; + +subtest 'post_with_token: basic' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = %$default; + $t->post_with_token_ok("$path?ACTION=edit_cred", \%form); + # note $t->content; + } +}; + +subtest 'post_with_token: edit with CENSORED email' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + Test::PAUSE::Web->setup; + $t->mod_db->update('users', { email => 'CENSORED' }, { userid => $user }); + my %form = (%$default, pause99_edit_cred_email => 'CENSORED'); + $t->post_with_token_ok("$path?ACTION=edit_cred", \%form); + my @deliveries = $t->deliveries; + like $deliveries[0]->as_string => qr/\[CENSORED\]/; + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/edit_ml.t b/t/pause_2025/action/edit_ml.t new file mode 100644 index 000000000..535653cd9 --- /dev/null +++ b/t/pause_2025/action/edit_ml.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=edit_ml"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/edit_uris.t b/t/pause_2025/action/edit_uris.t new file mode 100644 index 000000000..80c882fdc --- /dev/null +++ b/t/pause_2025/action/edit_uris.t @@ -0,0 +1,45 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +my $default_for_add_uri = { + pause99_add_uri_httpupload => ["$Test::PAUSE::Web::AppRoot/t/staging/Hash-RenameKey-0.02.tar.gz", "Hash-RenameKey-0.02.tar.gz"], + SUBMIT_pause99_add_uri_httpupload => 1, +}; + +my $default = { + pause99_edit_uris_3 => "T/TE/TESTUSER/Hash-RenameKey-0.02.tar.gz", + pause99_edit_uris_2 => 1, +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=edit_uris"); + # note $t->content; + } +}; + +subtest 'post: basic' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->mod_dbh->do("TRUNCATE uris"); + + # prepare distribution + $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + + my %form = %$default; + $form{pause99_edit_uris_3} =~ s/TESTUSER/$user/; + $t->post_ok("$path?ACTION=edit_uris", \%form); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/email_for_admin.t b/t/pause_2025/action/email_for_admin.t new file mode 100644 index 000000000..4d86b2991 --- /dev/null +++ b/t/pause_2025/action/email_for_admin.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=email_for_admin"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/giveup_comaint.t b/t/pause_2025/action/giveup_comaint.t new file mode 100644 index 000000000..c1cb6e4f0 --- /dev/null +++ b/t/pause_2025/action/giveup_comaint.t @@ -0,0 +1,112 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_share_perms_remome_m => "Module::Comaint", + SUBMIT_pause99_share_perms_remome => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=giveup_comaint"); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Comaint + Module::Comaint::Foo + Module::User::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::Comaint + Module::Comaint::Foo + /]) or note explain \@modules; + } + # note $t->content; + } +}; + +subtest 'normal case (comaint)' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_share_perms_remome_m => [qw/Module::Comaint Module::Comaint::Foo/], + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=giveup_comaint", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::User::Foo + /]) or note explain \@modules; + eq_or_diff(\@results, [ + 'Removed TESTADMIN from co-maintainers of Module::Comaint.', + 'Removed TESTADMIN from co-maintainers of Module::Comaint::Foo.', + ]); + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + /]) or note explain \@modules; + eq_or_diff(\@results, [ + 'Removed TESTUSER from co-maintainers of Module::Comaint.', + 'Removed TESTUSER from co-maintainers of Module::Comaint::Foo.', + ]); + } + # note $t->content; + } +}; + +subtest 'unrelated modules' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_share_perms_remome_m => [qw/Module::Unrelated Module::Unrelated::Foo/], + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=giveup_comaint", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Comaint + Module::Comaint::Foo + Module::User::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::Comaint + Module::Comaint::Foo + /]) or note explain \@modules; + } + ok !@results; + eq_or_diff(\@errors, [ + 'You do not seem to be co-maintainer of Module::Unrelated' + ]) or note explain \@errors; + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/giveup_dist_comaint.t b/t/pause_2025/action/giveup_dist_comaint.t new file mode 100644 index 000000000..7e4e97a91 --- /dev/null +++ b/t/pause_2025/action/giveup_dist_comaint.t @@ -0,0 +1,109 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_giveup_dist_comaint_d => "Module-Comaint", + SUBMIT_pause99_giveup_dist_comaint => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + Test::PAUSE::Web->reset_module_fixture; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=giveup_dist_comaint"); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + Module-Comaint + Module-User + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + Module-Comaint + /]) or note explain \@dists; + } + # note $t->content; + } +}; + +subtest 'normal case (comaint)' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_giveup_dist_comaint_d => [qw/Module-Comaint/], + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=giveup_dist_comaint", \%form); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + Module-User + /]) or note explain \@dists; + eq_or_diff(\@results, [ + 'Removed TESTADMIN from co-maintainers of Module::Comaint (Module-Comaint).', + 'Removed TESTADMIN from co-maintainers of Module::Comaint::Foo (Module-Comaint).', + ]); + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + /]) or note explain \@dists; + eq_or_diff(\@results, [ + 'Removed TESTUSER from co-maintainers of Module::Comaint (Module-Comaint).', + 'Removed TESTUSER from co-maintainers of Module::Comaint::Foo (Module-Comaint).', + ]); + } + # note $t->content; + } +}; + +subtest 'unrelated dists' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_giveup_dist_comaint_d => [qw/Module-Unrelated/], + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=giveup_dist_comaint", \%form); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + Module-Comaint + Module-User + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + Module-Comaint + /]) or note explain \@dists; + } + ok !@results; + eq_or_diff(\@errors, [ + 'You do not seem to be co-maintainer of Module-Unrelated' + ]) or note explain \@errors; + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/mailpw.t b/t/pause_2025/action/mailpw.t new file mode 100644 index 000000000..5aadcfe7e --- /dev/null +++ b/t/pause_2025/action/mailpw.t @@ -0,0 +1,175 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +my $default = { + pause99_mailpw_1 => "TESTUSER", + pause99_mailpw_sub => 1, +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=mailpw"); + #note $t->content; + } +}; + +subtest 'post: basic' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$default; + $t->authen_dbh->do("TRUNCATE abrakadabra"); + my $res = $t->post("$path?ACTION=mailpw", \%form); + ok !$res->is_success && $res->code == 403, "Forbidden"; + like $res->content => qr/Failed CSRF check/; + # note $t->content; + } +}; + +subtest 'post_with_token: basic' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$default; + $t->authen_dbh->do("TRUNCATE abrakadabra"); + $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + ->text_like("p.form_response", qr/A token to change the password/); + # note $t->content; + } +}; + +subtest 'got an email instead of a userid' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_mailpw_1 => 'INV@LID', + ); + $t->authen_dbh->do("TRUNCATE abrakadabra"); + $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + ->text_is('h2', 'Error') + ->text_like('p.error_message', qr/Please supply a userid/s); + } +}; + +subtest 'invalid userid' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_mailpw_1 => 'INV#LID', + ); + $t->authen_dbh->do("TRUNCATE abrakadabra"); + $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + ->text_is('h2', 'Error') + ->text_like('p.error_message', qr/A userid of INV#LID is not allowed/s); + } +}; + +subtest 'cannot find a userid' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_mailpw_1 => 'NOTFOUND', + ); + $t->authen_dbh->do("TRUNCATE abrakadabra"); + $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + ->text_is('h2', 'Error') + ->text_like('p.error_message', qr/Cannot find a userid.+NOTFOUND/s); + # note $t->content; + } +}; + +subtest 'no secretmail' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + ); + $t->authen_dbh->do("TRUNCATE abrakadabra"); + $t->authen_db->update('usertable', {secretemail => undef}, {user => "TESTUSER"}); + $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + ->text_like("p.form_response", qr/A token to change the password/); + # note $t->content; + } + + Test::PAUSE::Web->setup; # restore the original state +}; + +subtest 'requested recently' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$default; + $t->authen_dbh->do("TRUNCATE abrakadabra"); + $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + ->text_like("p.form_response", qr/A token to change the password/); + $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + ->text_is('h2', 'Error') + ->text_like('p.error_message', qr/A token for TESTUSER that allows/s); + # note $t->content; + } +}; + +subtest 'user without an entry in usertable: has email' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_mailpw_1 => "OTHERUSER", + ); + $t->authen_dbh->do("TRUNCATE abrakadabra"); + $t->mod_db->insert('users', { + userid => 'OTHERUSER', + email => 'foo@localhost', + }, {replace => 1}); + $t->authen_db->delete('usertable', {user => 'OTHERUSER'}); + ok !@{ $t->authen_db->select('usertable', ['user'], {user => 'OTHERUSER'}) // [] }; + $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + ->text_like("p.form_response", qr/A token to change the password/); + + # new usertable entry is created + ok @{ $t->authen_db->select('usertable', ['user'], {user => 'OTHERUSER'}) // [] }; + #note $t->content; + } +}; + +subtest 'user without an entry in usertable: without email' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_mailpw_1 => "OTHERUSER", + ); + $t->authen_dbh->do("TRUNCATE abrakadabra"); + $t->mod_db->insert('users', { + userid => 'OTHERUSER', + email => '', + }, {replace => 1}); + $t->authen_db->delete('usertable', {user => 'OTHERUSER'}); + ok !@{ $t->authen_db->select('usertable', ['user'], {user => 'OTHERUSER'}) // [] }; + $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + ->text_is('h2', 'Error') + ->text_like('p.error_message', qr/A userid of OTHERUSER\s+is not known/s); + + # new usertable entry is not created + ok !@{ $t->authen_db->select('usertable', ['user'], {user => 'OTHERUSER'}) // [] }; + #note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/make_comaint.t b/t/pause_2025/action/make_comaint.t new file mode 100644 index 000000000..0263244b6 --- /dev/null +++ b/t/pause_2025/action/make_comaint.t @@ -0,0 +1,170 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_share_perms_makeco_m => [], + pause99_share_perms_makeco_a => "TESTUSER2", + SUBMIT_pause99_share_perms_makeco => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=make_comaint"); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_set(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + } + # note $t->content; + } +}; + +subtest 'normal case' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @packages; + if ($user eq 'TESTADMIN') { + @packages = qw/Module::Admin::Bar/; + } + if ($user eq 'TESTUSER') { + @packages = qw/Module::User::Bar/; + } + + my %form = ( + %$default, + pause99_share_perms_makeco_m => \@packages, + pause99_share_perms_makeco_a => "TESTUSER4", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=make_comaint", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + eq_or_diff(\@results, [ + 'Added TESTUSER4 to co-maintainers of Module::Admin::Bar.', + ]); + } + if ($user eq 'TESTUSER') { + cmp_set(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + eq_or_diff(\@results, [ + 'Added TESTUSER4 to co-maintainers of Module::User::Bar.', + ]); + } + note $t->content; + } +}; +done_testing;exit; + +subtest 'unknown user' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @packages; + if ($user eq 'TESTADMIN') { + @packages = qw/Module::Admin::Bar/; + } + if ($user eq 'TESTUSER') { + @packages = qw/Module::User::Bar/; + } + + my %form = ( + %$default, + pause99_share_perms_makeco_m => \@packages, + pause99_share_perms_makeco_a => "UNKNOWN", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=make_comaint", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + } + ok !@results; + eq_or_diff(\@errors, [ + 'UNKNOWN is not a valid userid.', + ]); + # note $t->content; + } +}; + +subtest 'unrelated modules' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_share_perms_makeco_m => [qw/Module::Unrelated/], + pause99_share_perms_makeco_a => "TESTUSER2", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=make_comaint", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + } + ok !@results; + eq_or_diff(\@errors, [ + 'You do not seem to be maintainer of Module::Unrelated', + ]); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/make_dist_comaint.t b/t/pause_2025/action/make_dist_comaint.t new file mode 100644 index 000000000..2bd1cc9d3 --- /dev/null +++ b/t/pause_2025/action/make_dist_comaint.t @@ -0,0 +1,165 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_make_dist_comaint_d => [], + pause99_make_dist_comaint_a => "TESTUSER2", + SUBMIT_pause99_make_dist_comaint => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=make_dist_comaint"); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@dists, [qw/ + Module-Admin + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_set(\@dists, [qw/ + Module-User + Module-User-Foo-Baz + /]) or note explain \@dists; + } + + # note $t->content; + } +}; + +subtest 'normal case' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @dists; + if ($user eq 'TESTADMIN') { + @dists = qw/Module-Admin/; + } + if ($user eq 'TESTUSER') { + @dists = qw/Module-User/; + } + + my %form = ( + %$default, + pause99_make_dist_comaint_d => \@dists, + pause99_make_dist_comaint_a => "TESTUSER4", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=make_dist_comaint", \%form); + @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@dists, [qw/ + Module-Admin + /]) or note explain \@dists; + eq_or_diff(\@results, [ + 'Added TESTUSER4 to co-maintainers of Module::Admin::Bar (Module-Admin).', + 'Added TESTUSER4 to co-maintainers of Module::Admin::Foo (Module-Admin).', + ]); + } + if ($user eq 'TESTUSER') { + cmp_set(\@dists, [qw/ + Module-User + Module-User-Foo-Baz + /]) or note explain \@dists; + eq_or_diff(\@results, [ + 'Added TESTUSER4 to co-maintainers of Module::User::Bar (Module-User).', + 'Added TESTUSER4 to co-maintainers of Module::User::Foo (Module-User).', + ]); + } + + # note $t->content; + } +}; + +subtest 'unknown user' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @dists; + if ($user eq 'TESTADMIN') { + @dists = qw/Module-Admin/; + } + if ($user eq 'TESTUSER') { + @dists = qw/Module-User/; + } + + my %form = ( + %$default, + pause99_make_dist_comaint_d => \@dists, + pause99_make_dist_comaint_a => "UNKNOWN", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=make_dist_comaint", \%form); + @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + Module-Admin + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + Module-User + Module-User-Foo-Baz + /]) or note explain \@dists; + } + ok !@results; + eq_or_diff(\@errors, [ + 'UNKNOWN is not a valid userid.', + ]); + # note $t->content; + } +}; + +subtest 'unrelated dists' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_make_dist_comaint_d => [qw/Module-Unrelated/], + pause99_make_dist_comaint_a => "TESTUSER2", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=make_dist_comaint", \%form); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + Module-Admin + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + Module-User + Module-User-Foo-Baz + /]) or note explain \@dists; + } + ok !@results; + eq_or_diff(\@errors, [ + 'You do not seem to be maintainer of Module-Unrelated', + ]); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/manage_id_requests.t b/t/pause_2025/action/manage_id_requests.t new file mode 100644 index 000000000..9113a3a83 --- /dev/null +++ b/t/pause_2025/action/manage_id_requests.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=manage_id_requests"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/move_dist_primary.t b/t/pause_2025/action/move_dist_primary.t new file mode 100644 index 000000000..bcbd2132f --- /dev/null +++ b/t/pause_2025/action/move_dist_primary.t @@ -0,0 +1,161 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_move_dist_primary_d => [], + pause99_move_dist_primary_a => "TESTUSER2", + SUBMIT_pause99_move_dist_primary => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=move_dist_primary"); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + Module-Admin + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + Module-User + Module-User-Foo-Baz + /]) or note explain \@dists; + } + # note $t->content; + } +}; + +subtest 'normal case' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @dists; + if ($user eq 'TESTADMIN') { + @dists = qw/Module-Admin/; + } + if ($user eq 'TESTUSER') { + @dists = qw/Module-User/; + } + + my %form = ( + %$default, + pause99_move_dist_primary_d => \@dists, + pause99_move_dist_primary_a => "TESTUSER2", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=move_dist_primary", \%form); + @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + /]) or note explain \@dists; + eq_or_diff(\@results, [ + 'Made TESTUSER2 primary maintainer of Module::Admin::Bar (Module-Admin).', + 'Made TESTUSER2 primary maintainer of Module::Admin::Foo (Module-Admin).', + ]); + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + Module-User-Foo-Baz + /]) or note explain \@dists; + eq_or_diff(\@results, [ + 'Made TESTUSER2 primary maintainer of Module::User::Bar (Module-User).', + 'Made TESTUSER2 primary maintainer of Module::User::Foo (Module-User).', + ]); + } + note $t->content; + } +}; + +subtest 'unknown user' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @dists; + if ($user eq 'TESTADMIN') { + @dists = qw/Module-Admin/; + } + if ($user eq 'TESTUSER') { + @dists = qw/Module-User/; + } + + my %form = ( + %$default, + pause99_move_dist_primary_d => \@dists, + pause99_move_dist_primary_a => "UNKNOWN", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=move_dist_primary", \%form); + my @new_dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@new_dists, [qw/ + Module-Admin + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@new_dists, [qw/ + Module-User + Module-User-Foo-Baz + /]) or note explain \@dists; + } + ok !@results; + eq_or_diff(\@errors, [ + 'UNKNOWN is not a valid userid.', + ]); + # note $t->content; + } +}; + +subtest 'unrelated dists' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_move_dist_primary_d => [qw/Module-Unrelated/], + pause99_move_dist_primary_a => "TESTUSER2", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=move_dist_primary", \%form); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + Module-Admin + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + Module-User + Module-User-Foo-Baz + /]) or note explain \@dists; + } + ok !@results; + eq_or_diff(\@errors, [ + 'You do not seem to be maintainer of Module-Unrelated', + ]); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/move_primary.t b/t/pause_2025/action/move_primary.t new file mode 100644 index 000000000..e9a739229 --- /dev/null +++ b/t/pause_2025/action/move_primary.t @@ -0,0 +1,168 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_share_perms_pr_m => [], + pause99_share_perms_movepr_a => "TESTUSER2", + SUBMIT_pause99_share_perms_movepr => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=move_primary"); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + } + # note $t->content; + } +}; + +subtest 'normal case' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @packages; + if ($user eq 'TESTADMIN') { + @packages = qw/Module::Admin::Bar/; + } + if ($user eq 'TESTUSER') { + @packages = qw/Module::User::Bar/; + } + + my %form = ( + %$default, + pause99_share_perms_pr_m => \@packages, + pause99_share_perms_movepr_a => "TESTUSER2", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=move_primary", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Admin::Foo + /]) or note explain \@modules; + eq_or_diff(\@results, [ + 'Made TESTUSER2 primary maintainer of Module::Admin::Bar.', + ]); + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + eq_or_diff(\@results, [ + 'Made TESTUSER2 primary maintainer of Module::User::Bar.', + ]); + } + # note $t->content; + } +}; + +subtest 'unknown user' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @packages; + if ($user eq 'TESTADMIN') { + @packages = qw/Module::Admin::Bar/; + } + if ($user eq 'TESTUSER') { + @packages = qw/Module::User::Bar/; + } + + my %form = ( + %$default, + pause99_share_perms_pr_m => \@packages, + pause99_share_perms_movepr_a => "UNKNOWN", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=move_primary", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + } + ok !@results; + eq_or_diff(\@errors, [ + 'UNKNOWN is not a valid userid.', + ]); + # note $t->content; + } +}; + +subtest 'unrelated modules' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_share_perms_pr_m => [qw/Module::Unrelated/], + pause99_share_perms_movepr_a => "TESTUSER2", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=move_primary", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + } + ok !@results; + eq_or_diff(\@errors, [ + 'You do not seem to be maintainer of Module::Unrelated', + ]); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/pause_04about.t b/t/pause_2025/action/pause_04about.t new file mode 100644 index 000000000..05773616f --- /dev/null +++ b/t/pause_2025/action/pause_04about.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=pause_04about"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/pause_04imprint.t b/t/pause_2025/action/pause_04imprint.t new file mode 100644 index 000000000..780605e78 --- /dev/null +++ b/t/pause_2025/action/pause_04imprint.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=pause_04imprint"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/pause_05news.t b/t/pause_2025/action/pause_05news.t new file mode 100644 index 000000000..e033387c2 --- /dev/null +++ b/t/pause_2025/action/pause_05news.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=pause_05news"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/pause_06history.t b/t/pause_2025/action/pause_06history.t new file mode 100644 index 000000000..79aed17ab --- /dev/null +++ b/t/pause_2025/action/pause_06history.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=pause_06history"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/pause_logout.t b/t/pause_2025/action/pause_logout.t new file mode 100644 index 000000000..2459230d3 --- /dev/null +++ b/t/pause_2025/action/pause_logout.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=pause_logout"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/pause_namingmodules.t b/t/pause_2025/action/pause_namingmodules.t new file mode 100644 index 000000000..443064d5d --- /dev/null +++ b/t/pause_2025/action/pause_namingmodules.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=pause_namingmodules"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/pause_operating_model.t b/t/pause_2025/action/pause_operating_model.t new file mode 100644 index 000000000..c502086ba --- /dev/null +++ b/t/pause_2025/action/pause_operating_model.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=pause_operating_model"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/pause_privacy_policy.t b/t/pause_2025/action/pause_privacy_policy.t new file mode 100644 index 000000000..d33518728 --- /dev/null +++ b/t/pause_2025/action/pause_privacy_policy.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=pause_privacy_policy"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/peek_dist_perms.t b/t/pause_2025/action/peek_dist_perms.t new file mode 100644 index 000000000..52532ea24 --- /dev/null +++ b/t/pause_2025/action/peek_dist_perms.t @@ -0,0 +1,172 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use YAML::Syck; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_peek_dist_perms_query => "TESTUSER", + pause99_peek_dist_perms_by => "a", + pause99_peek_dist_perms_sub => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=peek_dist_perms"); + # note $t->content; + } +}; + +subtest 'search by author' => sub { + for my $method (qw/get_ok post_ok/) { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_peek_dist_perms_query => $user, + ); + $t->$method("$path?ACTION=peek_dist_perms", \%form); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + Module-Admin + Module-Comaint + Module-User + /]) or note explain \@dists; + ok grep(/^Module-Comaint/, @dists), 'Module-Comaint is also listed'; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + Module-Comaint + Module-User + Module-User-Foo-Baz + /]) or note explain \@dists; + } + # note $t->content; + + $t->$method("$path?ACTION=peek_dist_perms&OF=YAML", \%form); + my $list = YAML::Syck::Load( $t->content ); + if ($user eq 'TESTADMIN') { + eq_or_diff( $list => [ + { + 'dist' => 'Module-Admin', + 'owner' => 'TESTADMIN', + 'comaint' => 'TESTUSER2', + }, + { + 'dist' => 'Module-Comaint', + 'owner' => 'TESTUSER2', + 'comaint' => 'TESTADMIN', + }, + { + 'dist' => 'Module-User', + 'owner' => 'TESTUSER', + 'comaint' => 'TESTADMIN', + }, + ] ); + } + if ($user eq 'TESTUSER') { + eq_or_diff( $list => [ + { + 'dist' => 'Module-Comaint', + 'owner' => 'TESTUSER2', + 'comaint' => 'TESTUSER', + }, + { + 'dist' => 'Module-User', + 'owner' => 'TESTUSER', + 'comaint' => 'TESTADMIN,TESTUSER2', + }, + { + 'dist' => 'Module-User-Foo-Baz', + 'owner' => 'TESTUSER', + 'comaint' => undef, + }, + ] ); + } + } + } +}; + +subtest 'search by dist (exact)' => sub { + for my $method (qw/get_ok post_ok/) { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_peek_dist_perms_query => 'Module-User', + pause99_peek_dist_perms_by => 'de', + ); + $t->$method("$path?ACTION=peek_dist_perms", \%form); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + cmp_set(\@dists, [qw/ + Module-User + /]) or note explain \@dists; + # note $t->content; + + $t->$method("$path?ACTION=peek_dist_perms&OF=YAML", \%form); + my $list = YAML::Syck::Load( $t->content ); + eq_or_diff( $list => [ + { + 'dist' => 'Module-User', + 'owner' => 'TESTUSER', + 'comaint' => 'TESTADMIN,TESTUSER2', + }, + ]); + } + } +}; + +subtest 'search by module (sql-like)' => sub { + for my $method (qw/get_ok post_ok/) { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_peek_dist_perms_query => 'Module-User%', + pause99_peek_dist_perms_by => 'dl', + ); + $t->$method("$path?ACTION=peek_dist_perms", \%form); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + cmp_set(\@dists, [qw/ + Module-User + Module-User-Foo-Baz + /]) or note explain \@dists; + # note $t->content; + + $t->$method("$path?ACTION=peek_dist_perms&OF=YAML", \%form); + my $list = YAML::Syck::Load( $t->content ); + eq_or_diff( $list => [ + { + 'dist' => 'Module-User', + 'owner' => 'TESTUSER', + 'comaint' => 'TESTADMIN,TESTUSER2', + }, + { + 'dist' => 'Module-User-Foo-Baz', + 'owner' => 'TESTUSER', + 'comaint' => undef, + }, + ]); + } + } +}; + +done_testing; diff --git a/t/pause_2025/action/peek_perms.t b/t/pause_2025/action/peek_perms.t new file mode 100644 index 000000000..74f816693 --- /dev/null +++ b/t/pause_2025/action/peek_perms.t @@ -0,0 +1,240 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use YAML::Syck; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_peek_perms_query => "TESTUSER", + pause99_peek_perms_by => "a", + pause99_peek_perms_sub => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=peek_perms"); + # note $t->content; + } +}; + +subtest 'search by author' => sub { + for my $method (qw/get_ok post_ok/) { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_peek_perms_query => $user, + ); + $t->$method("$path?ACTION=peek_perms", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.module')->each; + my @types = map {$_->all_text} $t->dom->find('td.type')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + Module::Comaint + Module::Comaint::Foo + Module::User::Foo + /]) or note explain \@modules; + ok grep(/co-maint/, @types), 'Has co-maint'; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::Comaint + Module::Comaint::Foo + Module::User::Bar + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + ok grep(/co-maint/, @types), 'No co-maint'; + } + # note $t->content; + + $t->$method("$path?ACTION=peek_perms&OF=YAML", \%form); + my $list = YAML::Syck::Load( $t->content ); + if ($user eq 'TESTADMIN') { + eq_or_diff( $list => [ + { + 'module' => 'Module::Admin::Bar', + 'owner' => 'TESTADMIN', + 'type' => 'first-come', + 'userid' => 'TESTADMIN' + }, + { + 'module' => 'Module::Admin::Foo', + 'owner' => 'TESTADMIN', + 'type' => 'first-come', + 'userid' => 'TESTADMIN' + }, + { + 'module' => 'Module::User::Foo', + 'owner' => 'TESTUSER', + 'type' => 'co-maint', + 'userid' => 'TESTADMIN' + }, + { + 'module' => 'Module::Comaint', + 'owner' => 'TESTUSER2', + 'type' => 'co-maint', + 'userid' => 'TESTADMIN' + }, + { + 'module' => 'Module::Comaint::Foo', + 'owner' => 'TESTUSER2', + 'type' => 'co-maint', + 'userid' => 'TESTADMIN' + }, + ] ); + } + if ($user eq 'TESTUSER') { + eq_or_diff( $list => [ + { + 'module' => 'Module::User::Bar', + 'owner' => 'TESTUSER', + 'type' => 'first-come', + 'userid' => 'TESTUSER' + }, + { + 'module' => 'Module::User::Foo', + 'owner' => 'TESTUSER', + 'type' => 'first-come', + 'userid' => 'TESTUSER' + }, + { + 'module' => 'Module::User::Foo::Baz', + 'owner' => 'TESTUSER', + 'type' => 'first-come', + 'userid' => 'TESTUSER' + }, + { + 'module' => 'Module::Comaint', + 'owner' => 'TESTUSER2', + 'type' => 'co-maint', + 'userid' => 'TESTUSER' + }, + { + 'module' => 'Module::Comaint::Foo', + 'owner' => 'TESTUSER2', + 'type' => 'co-maint', + 'userid' => 'TESTUSER' + }, + ] ); + } + } + } +}; + +subtest 'search by module (exact)' => sub { + for my $method (qw/get_ok post_ok/) { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_peek_perms_query => 'Module::User::Foo', + pause99_peek_perms_by => 'me', + ); + $t->$method("$path?ACTION=peek_perms", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.module')->each; + my @types = map {$_->all_text} $t->dom->find('td.type')->each; + cmp_set(\@modules, [qw/ + Module::User::Foo + /]) or note explain \@modules; + ok grep(/co-maint/, @types), 'Has co-maint'; + # note $t->content; + + $t->$method("$path?ACTION=peek_perms&OF=YAML", \%form); + my $list = YAML::Syck::Load( $t->content ); + eq_or_diff( $list => [ + { + 'module' => 'Module::User::Foo', + 'owner' => 'TESTUSER', + 'type' => 'first-come', + 'userid' => 'TESTUSER' + }, + { + 'module' => 'Module::User::Foo', + 'owner' => 'TESTUSER', + 'type' => 'co-maint', + 'userid' => 'TESTADMIN' + }, + ]); + } + } +}; + +subtest 'search by module (sql-like)' => sub { + for my $method (qw/get_ok post_ok/) { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_peek_perms_query => 'Module::User::%', + pause99_peek_perms_by => 'ml', + ); + $t->$method("$path?ACTION=peek_perms", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.module')->each; + my @types = map {$_->all_text} $t->dom->find('td.type')->each; + cmp_set(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + ok grep(/co-maint/, @types), 'Has co-maint'; + # note $t->content; + + $t->$method("$path?ACTION=peek_perms&OF=YAML", \%form); + my $list = YAML::Syck::Load( $t->content ); + eq_or_diff( $list => [ + { + 'module' => 'Module::User::Bar', + 'owner' => 'TESTUSER', + 'type' => 'first-come', + 'userid' => 'TESTUSER' + }, + { + 'module' => 'Module::User::Foo', + 'owner' => 'TESTUSER', + 'type' => 'first-come', + 'userid' => 'TESTUSER' + }, + { + 'module' => 'Module::User::Foo::Baz', + 'owner' => 'TESTUSER', + 'type' => 'first-come', + 'userid' => 'TESTUSER' + }, + { + 'module' => 'Module::User::Bar', + 'owner' => 'TESTUSER', + 'type' => 'co-maint', + 'userid' => 'TESTUSER2' + }, + { + 'module' => 'Module::User::Foo', + 'owner' => 'TESTUSER', + 'type' => 'co-maint', + 'userid' => 'TESTADMIN' + }, + ]); + } + } +}; + +done_testing; diff --git a/t/pause_2025/action/reindex.t b/t/pause_2025/action/reindex.t new file mode 100644 index 000000000..3d0df8430 --- /dev/null +++ b/t/pause_2025/action/reindex.t @@ -0,0 +1,47 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +my $default_for_add_uri = { + pause99_add_uri_httpupload => [Test::PAUSE::Web->file_to_upload], + SUBMIT_pause99_add_uri_httpupload => 1, +}; + +my $default = { + pause99_reindex_FILE => ["Hash-RemoteKey-0.02.tar.gz"], + SUBMIT_pause99_reindex_delete => 1, +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=reindex"); + # note $t->content; + } +}; + +subtest 'post: basic' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + my $t = Test::PAUSE::Web->new(user => $user); + + $t->mod_dbh->do("TRUNCATE uris"); + + # prepare distribution + $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + + $t->copy_to_authors_dir($user, scalar Test::PAUSE::Web->file_to_upload); + + my %form = %$default; + $t->post_ok("$path?ACTION=reindex", \%form); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/remove_comaint.t b/t/pause_2025/action/remove_comaint.t new file mode 100644 index 000000000..752dcba37 --- /dev/null +++ b/t/pause_2025/action/remove_comaint.t @@ -0,0 +1,172 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_share_perms_remocos_tuples => [], + SUBMIT_pause99_share_perms_remocos => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=remove_comaint"); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_set(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + /]) or note explain \@modules; + } + # note $t->content; + } +}; + +subtest 'normal case' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @tuples; + if ($user eq 'TESTADMIN') { + @tuples = ( + 'Module::Admin::Bar -- TESTUSER2', + ); + } + if ($user eq 'TESTUSER') { + @tuples = ( + 'Module::User::Bar -- TESTUSER2', + ); + + } + + my %form = ( + %$default, + pause99_share_perms_remocos_tuples => \@tuples, + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=remove_comaint", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@modules, [qw/ + Module::Admin::Foo + /]) or note explain \@modules; + eq_or_diff(\@results, [ + 'Removed TESTUSER2 from co-maintainers of Module::Admin::Bar.', + ]); + } + if ($user eq 'TESTUSER') { + cmp_set(\@modules, [qw/ + Module::User::Foo + /]) or note explain \@modules; + eq_or_diff(\@results, [ + 'Removed TESTUSER2 from co-maintainers of Module::User::Bar.', + ]); + } + # note $t->content; + } +}; + +subtest 'broken tuple (not the owner)' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_share_perms_remocos_tuples => ['Module::Unrelated -- TESTUSER2'], + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=remove_comaint", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_set(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + /]) or note explain \@modules; + } + ok !@results; + eq_or_diff(\@errors, [ + 'You do not seem to be owner of Module::Unrelated.', + ]); + # note $t->content; + } +}; + +subtest 'broken tuple (not the comaint)' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @tuples; + if ($user eq 'TESTADMIN') { + @tuples = ( + 'Module::Admin::Bar -- TESTUSER4', + ); + } + if ($user eq 'TESTUSER') { + @tuples = ( + 'Module::User::Bar -- TESTUSER4', + ); + + } + + my %form = ( + %$default, + pause99_share_perms_remocos_tuples => \@tuples, + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=remove_comaint", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + eq_or_diff(\@errors, [ + 'Cannot handle tuple Module::Admin::Bar -- TESTUSER4. If you believe, this is a bug, please complain.' + ]); + } + if ($user eq 'TESTUSER') { + cmp_set(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + /]) or note explain \@modules; + eq_or_diff(\@errors, [ + 'Cannot handle tuple Module::User::Bar -- TESTUSER4. If you believe, this is a bug, please complain.' + ]); + } + ok !@results; + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/remove_dist_comaint.t b/t/pause_2025/action/remove_dist_comaint.t new file mode 100644 index 000000000..db476fde3 --- /dev/null +++ b/t/pause_2025/action/remove_dist_comaint.t @@ -0,0 +1,166 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_remove_dist_comaint_tuples => [], + SUBMIT_pause99_remove_dist_comaint => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=remove_dist_comaint"); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@dists, [qw/ + Module-Admin + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_set(\@dists, [qw/ + Module-User + /]) or note explain \@dists; + } + # note $t->content; + } +}; + +subtest 'normal case' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @tuples; + if ($user eq 'TESTADMIN') { + @tuples = ( + 'Module-Admin -- TESTUSER2', + ); + } + if ($user eq 'TESTUSER') { + @tuples = ( + 'Module-User -- TESTUSER2', + ); + } + + my %form = ( + %$default, + pause99_remove_dist_comaint_tuples => \@tuples, + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=remove_dist_comaint", \%form); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@dists, [qw/ + /]) or note explain \@dists; + eq_or_diff(\@results, [ + 'Removed TESTUSER2 from co-maintainers of Module::Admin::Bar (Module-Admin).', + 'Removed TESTUSER2 from co-maintainers of Module::Admin::Foo (Module-Admin).', + ]); + } + if ($user eq 'TESTUSER') { + cmp_set(\@dists, [qw/ + Module-User + /]) or note explain \@dists; + eq_or_diff(\@results, [ + 'Removed TESTUSER2 from co-maintainers of Module::User::Bar (Module-User).', + 'Removed TESTUSER2 from co-maintainers of Module::User::Foo (Module-User).', + ]); + } + # note $t->content; + } +}; + +subtest 'broken tuple (not an owner)' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_remove_dist_comaint_tuples => ['Module-Unrelated -- TESTUSER2'], + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=remove_dist_comaint", \%form); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@dists, [qw/ + Module-Admin + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_set(\@dists, [qw/ + Module-User + /]) or note explain \@dists; + } + ok !@results; + eq_or_diff(\@errors, [ + 'You do not seem to be owner of Module-Unrelated.', + ]); + # note $t->content; + } +}; + +subtest 'broken tuple (not a comaint)' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @tuples; + if ($user eq 'TESTADMIN') { + @tuples = ( + 'Module-Admin -- TESTUSER4', + ); + } + if ($user eq 'TESTUSER') { + @tuples = ( + 'Module-User -- TESTUSER4', + ); + + } + + my %form = ( + %$default, + pause99_remove_dist_comaint_tuples => \@tuples, + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=remove_dist_comaint", \%form); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@dists, [qw/ + Module-Admin + /]) or note explain \@dists; + eq_or_diff(\@errors, [ + 'Cannot handle tuple Module-Admin -- TESTUSER4. If you believe, this is a bug, please complain.', + ]); + } + if ($user eq 'TESTUSER') { + cmp_set(\@dists, [qw/ + Module-User + /]) or note explain \@dists; + eq_or_diff(\@errors, [ + 'Cannot handle tuple Module-User -- TESTUSER4. If you believe, this is a bug, please complain.', + ]); + } + ok !@results; + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/remove_dist_primary.t b/t/pause_2025/action/remove_dist_primary.t new file mode 100644 index 000000000..06d7c3342 --- /dev/null +++ b/t/pause_2025/action/remove_dist_primary.t @@ -0,0 +1,134 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_remove_dist_primary_d => [], + SUBMIT_pause99_remove_dist_primary => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=remove_dist_primary"); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + Module-Admin + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + Module-User + Module-User-Foo-Baz + /]) or note explain \@dists; + } + # note $t->content; + } +}; + +subtest 'normal case' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @dists; + if ($user eq 'TESTADMIN') { + @dists = qw/Module-Admin/; + } + if ($user eq 'TESTUSER') { + @dists = qw/Module-User/; + } + + my %form = ( + %$default, + pause99_remove_dist_primary_d => \@dists, + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=remove_dist_primary", \%form); + @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + /]) or note explain \@dists; + eq_or_diff(\@results, [ + 'Removed primary maintainership of TESTADMIN from Module::Admin::Bar (Module-Admin).', + 'Removed primary maintainership of TESTADMIN from Module::Admin::Foo (Module-Admin).', + ]); + + # really transferred to ADOPTME? + $t->get_ok("$path?ACTION=peek_dist_perms", { + pause99_peek_dist_perms_query => "ADOPTME", + pause99_peek_dist_perms_by => "a", + pause99_peek_dist_perms_sub => 1, + }); + my @adoptme_dists = map {$_->all_text} $t->dom->find('td.dist')->each; + cmp_set(\@adoptme_dists, [qw/Module-Admin/]) or note explain \@adoptme_dists; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + Module-User-Foo-Baz + /]) or note explain \@dists; + eq_or_diff(\@results, [ + 'Removed primary maintainership of TESTUSER from Module::User::Bar (Module-User).', + 'Removed primary maintainership of TESTUSER from Module::User::Foo (Module-User).', + ]); + + # really transferred to ADOPTME? + $t->get_ok("$path?ACTION=peek_dist_perms", { + pause99_peek_dist_perms_query => "ADOPTME", + pause99_peek_dist_perms_by => "a", + pause99_peek_dist_perms_sub => 1, + }); + my @adoptme_dists = map {$_->all_text} $t->dom->find('td.dist')->each; + cmp_set(\@adoptme_dists, [qw/Module-User/]) or note explain \@adoptme_dists; + } + # note $t->content; + } +}; + +subtest 'unrelated dists' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_remove_dist_primary_d => [qw/Module-Unrelated/], + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=remove_dist_primary", \%form); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @warnings = map {$_->all_text} $t->dom->find('.warning')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + Module-Admin + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + Module-User + Module-User-Foo-Baz + /]) or note explain \@dists; + } + ok !@results; + eq_or_diff(\@warnings, [ + 'You need to select one or more distributions. Nothing done.', + ]); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/remove_primary.t b/t/pause_2025/action/remove_primary.t new file mode 100644 index 000000000..e6f82d58d --- /dev/null +++ b/t/pause_2025/action/remove_primary.t @@ -0,0 +1,138 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_share_perms_pr_m => [], + SUBMIT_pause99_share_perms_remopr => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=remove_primary"); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + } + # note $t->content; + } +}; + +subtest 'normal case' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @packages; + if ($user eq 'TESTADMIN') { + @packages = qw/Module::Admin::Bar/; + } + if ($user eq 'TESTUSER') { + @packages = qw/Module::User::Bar/; + } + + my %form = ( + %$default, + pause99_share_perms_pr_m => \@packages, + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=remove_primary", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Admin::Foo + /]) or note explain \@modules; + eq_or_diff(\@results, [ + 'Removed primary maintainership of TESTADMIN from Module::Admin::Bar.', + ]); + + # really transferred to ADOPTME? + $t->get_ok("$path?ACTION=peek_perms", { + pause99_peek_perms_query => "ADOPTME", + pause99_peek_perms_by => "a", + pause99_peek_perms_sub => 1, + }); + my @adoptme_modules = map {$_->all_text} $t->dom->find('td.module')->each; + cmp_set(\@adoptme_modules, [qw/Module::Admin::Bar/]) or note explain \@adoptme_modules; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + eq_or_diff(\@results, [ + 'Removed primary maintainership of TESTUSER from Module::User::Bar.', + ]); + + # really transferred to ADOPTME? + $t->get_ok("$path?ACTION=peek_perms", { + pause99_peek_perms_query => "ADOPTME", + pause99_peek_perms_by => "a", + pause99_peek_perms_sub => 1, + }); + my @adoptme_modules = map {$_->all_text} $t->dom->find('td.module')->each; + cmp_set(\@adoptme_modules, [qw/Module::User::Bar/]) or note explain \@adoptme_modules; + } + # note $t->content; + } +}; + +subtest 'unrelated modules' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_share_perms_pr_m => [qw/Module::Unrelated/], + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=remove_primary", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @warnings = map {$_->all_text} $t->dom->find('.warning')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + } + ok !@results; + eq_or_diff(\@warnings, [ + 'You need to select one or more packages. Nothing done.', + ]); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/request_id.t b/t/pause_2025/action/request_id.t new file mode 100644 index 000000000..8936d08bb --- /dev/null +++ b/t/pause_2025/action/request_id.t @@ -0,0 +1,273 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +my $default = { + pause99_request_id_fullname => 'full name', + pause99_request_id_email => 'test@localhost.localdomain', + pause99_request_id_homepage => 'none', + pause99_request_id_userid => 'NEWUSER', + pause99_request_id_rationale => 'Hello, my ratoinale is to test PAUSE', + SUBMIT_pause99_request_id_sub => 1, +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=request_id"); + # note $t->content; + } +}; + +subtest 'post: basic' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$default; + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_like("pre.email_sent", qr/Subject: PAUSE ID request \(NEWUSER/); + is $t->deliveries => 2, "two deliveries (one for admin, one for requester)"; + # note $t->content; + } +}; + +subtest 'post: thank you, bot' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + url => 'http://host/path', + ); + $t->post_ok("$path?ACTION=request_id", \%form); + is $t->content => "Thank you!"; + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: no space in full name' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_fullname => 'FULLNAME', + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h3", "Error processing form") + ->text_like("ul.errors li", qr/Name does not look like a full civil name/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: no full name' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_fullname => '', + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h3", "Error processing form") + ->text_like("ul.errors li", qr/You must supply a name/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: no email' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_email => '', + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h3", "Error processing form") + ->text_like("ul.errors li", qr/You must supply an email address/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: invalid email' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_email => 'no email', + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h3", "Error processing form") + ->text_like("ul.errors li", qr/Your email address doesn't look like valid email address./); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: rational is too short' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_rationale => 'rationale', + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h3", "Error processing form") + ->text_like("ul.errors li", qr/this looks a\s+bit too short/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +# XXX: might be better to ignore other attributes (or YAGNI) +subtest 'post: rational has html links' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_rationale => '', + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h3", "Error processing form") + ->text_like("ul.errors li", qr/Please do not use HTML links/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: multiple links' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_rationale => <<'SPAM', +http://spam/path +http://spam/path +SPAM + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h3", "Error processing form") + ->text_like("ul.errors li", qr/Please do not include more than one URL/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: no rationale' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_rationale => '', + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h3", "Error processing form") + ->text_like("ul.errors li", qr/You must supply a short description/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: userid is taken' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_userid => 'TESTUSER', + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h3", "Error processing form") + ->text_like("ul.errors li", qr/The userid TESTUSER is already taken/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: invalid userid' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_userid => 'INV#LID', + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h3", "Error processing form") + ->text_like("ul.errors li", qr/The userid INV#LID does not match/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: no userid' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_userid => '', + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h3", "Error processing form") + ->text_like("ul.errors li", qr/You must supply a desired user-ID/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: lots of .info' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_rationale => <<'SPAM', +ttp://spam.info +ttp://spam.info +ttp://spam.info +ttp://spam.info +ttp://spam.info +SPAM + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h2", "Error") + ->text_like("p.error_message", qr/rationale looks like spam/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: interesting .cn homepage' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_homepage => 'http://some.cn/index.htm', + pause99_request_id_rationale => 'interesting site', + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h2", "Error") + ->text_like("p.error_message", qr/rationale looks like spam/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/reset_version.t b/t/pause_2025/action/reset_version.t new file mode 100644 index 000000000..45c37dc89 --- /dev/null +++ b/t/pause_2025/action/reset_version.t @@ -0,0 +1,48 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +my $default = { + pause99_reset_version_PKG => ["Foo"], + SUBMIT_pause99_reset_version_forget => 1, +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=reset_version"); + # note $t->content; + } +}; + +subtest 'post: basic' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->mod_dbh->do("TRUNCATE packages"); + $t->mod_db->insert('packages', { + package => "Foo", + version => "0.01", + dist => "T/TE/$user/Foo-0.01.tar.gz", + file => "Foo-0.01.tar.gz", + }); + $t->mod_db->insert('packages', { + package => "Bar", + version => "0.02", + dist => "T/TE/$user/Bar-0.02.tar.gz", + file => "Bar-0.02.tar.gz", + }); + + my %form = %$default; + $t->post_ok("$path?ACTION=reset_version", \%form); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/select_ml_action.t b/t/pause_2025/action/select_ml_action.t new file mode 100644 index 000000000..75bda972b --- /dev/null +++ b/t/pause_2025/action/select_ml_action.t @@ -0,0 +1,49 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +my $mailing_list = { + SUBMIT_pause99_add_user_Definitely => 1, + pause99_add_user_userid => "MAILLIST", + pause99_add_user_email => "ml\@localhost.localdomain", + pause99_add_user_subscribe => "how to subscribe", +}; + +my $default = { + HIDDENNAME => "TESTUSER", + ACTIONREQ => "edit_ml", + pause99_select_ml_action_sub => 1, +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=select_ml_action"); + # note $t->content; + } +}; + +subtest 'post: basic' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->post_ok("$path?ACTION=add_user", $mailing_list); + + $t->mod_db->insert("list2user", { + maillistid => "MAILLIST", + userid => "TESTUSER", + }, {ignore => 1}); + + my %form = %$default; + $t->post_ok("$path?ACTION=select_ml_action", \%form); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/select_user.t b/t/pause_2025/action/select_user.t new file mode 100644 index 000000000..3d6ac280e --- /dev/null +++ b/t/pause_2025/action/select_user.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=select_user"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/share_perms.t b/t/pause_2025/action/share_perms.t new file mode 100644 index 000000000..76c4be7bf --- /dev/null +++ b/t/pause_2025/action/share_perms.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=share_perms"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/show_files.t b/t/pause_2025/action/show_files.t new file mode 100644 index 000000000..9c6b61797 --- /dev/null +++ b/t/pause_2025/action/show_files.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=show_files"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/show_ml_repr.t b/t/pause_2025/action/show_ml_repr.t new file mode 100644 index 000000000..2fc8bce41 --- /dev/null +++ b/t/pause_2025/action/show_ml_repr.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=show_ml_repr"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/tail_logfile.t b/t/pause_2025/action/tail_logfile.t new file mode 100644 index 000000000..49bb91888 --- /dev/null +++ b/t/pause_2025/action/tail_logfile.t @@ -0,0 +1,43 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +my $default = { + pause99_tail_logfile_1 => 5000, + pause99_tail_logfile_sub => 1, +}; + +Test::PAUSE::Web->setup; + +{ + open my $fh, '>', $PAUSE::Config->{PAUSE_LOG}; + say $fh < sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("/pause/authenquery?ACTION=tail_logfile"); + # note $t->content; + } +}; + +subtest 'post: basic' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = %$default; + $t->post_ok("$path?ACTION=tail_logfile", \%form); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action/who_admin.t b/t/pause_2025/action/who_admin.t new file mode 100644 index 000000000..f8a41cb07 --- /dev/null +++ b/t/pause_2025/action/who_admin.t @@ -0,0 +1,44 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use YAML::Syck (); + +Test::PAUSE::Web->setup; + +# SELECT user FROM grouptable WHERE ugroup='admin' order by user"); +subtest 'get' => sub { + Test::PAUSE::Web->authen_db->insert('grouptable', { + user => "FOO", + ugroup => "admin", + }); + Test::PAUSE::Web->authen_db->insert('grouptable', { + user => "BAR", + ugroup => "admin", + }); + Test::PAUSE::Web->authen_db->insert('grouptable', { + user => "BAZ", + ugroup => "bar", + }); + + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->get_ok("$path?ACTION=who_admin") + ->text_like('body', qr/Registered admins:\s+BAR, FOO/); + + $t->get_ok("$path?ACTION=who_admin&OF=YAML"); + my $list_amp = YAML::Syck::Load( $t->content ); + is_deeply( $list_amp, [qw/BAR FOO TESTADMIN/], "YAML output works" ); + + SKIP: { + skip "; is not supported anymore", 1; + $t->get_ok("$path?ACTION=who_admin;OF=YAML"); + my $list_sem = YAML::Syck::Load( $t->content ); + is_deeply( $list_sem, [qw/BAR FOO TESTADMIN/], "YAML output works" ); + } + } +}; + +done_testing; diff --git a/t/pause_2025/action/who_pumpkin.t b/t/pause_2025/action/who_pumpkin.t new file mode 100644 index 000000000..4e60d2bc5 --- /dev/null +++ b/t/pause_2025/action/who_pumpkin.t @@ -0,0 +1,44 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use YAML::Syck (); + +Test::PAUSE::Web->setup; + +# SELECT user FROM grouptable WHERE ugroup='pumpking' order by user"); +subtest 'get' => sub { + Test::PAUSE::Web->authen_db->insert('grouptable', { + user => "FOO", + ugroup => "pumpking", + }); + Test::PAUSE::Web->authen_db->insert('grouptable', { + user => "BAR", + ugroup => "pumpking", + }); + Test::PAUSE::Web->authen_db->insert('grouptable', { + user => "BAZ", + ugroup => "baz", + }); + + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->get_ok("$path?ACTION=who_pumpkin") + ->text_like("body", qr/Registered pumpkins:\s+BAR, FOO/); + + $t->get_ok("$path?ACTION=who_pumpkin&OF=YAML"); + my $list_amp = YAML::Syck::Load( $t->content ); + is_deeply( $list_amp, [qw/BAR FOO/], "YAML output works" ); + + SKIP: { + skip "; is not supported anymore", 1; + $t->get_ok("$path?ACTION=who_pumpkin;OF=YAML"); + my $list_sem = YAML::Syck::Load( $t->content ); + is_deeply( $list_sem, [qw/BAR FOO/], "YAML output works" ); + } + } +}; + +done_testing; diff --git a/t/pause_2025/auth.t b/t/pause_2025/auth.t new file mode 100644 index 000000000..78f0fd6a9 --- /dev/null +++ b/t/pause_2025/auth.t @@ -0,0 +1,62 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/lib"; +use Test::PAUSE::Web; +use HTTP::Status qw/:constants/; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'basic' => sub { + my $test = Test::PAUSE::Web->tests_for('user'); + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my $res = $t->get("$path");; + ok $res->is_success; +}; + +subtest 'lower case' => sub { + my $test = Test::PAUSE::Web->tests_for('user'); + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => lc $user); + my $res = $t->get("$path");; + ok $res->is_success; +}; + +subtest 'wrong password' => sub { + my $test = Test::PAUSE::Web->tests_for('user'); + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user, pass => "WRONG PASS"); + my $res = $t->get("$path");; + ok !$res->is_success; + is $res->code => HTTP_UNAUTHORIZED; +}; + +subtest 'unknown user' => sub { + my $test = Test::PAUSE::Web->tests_for('user'); + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => "UNKNOWN"); + my $res = $t->get("$path");; + ok !$res->is_success; + is $res->code => HTTP_UNAUTHORIZED; +}; + +subtest 'disallowed action for an anonymous user' => sub { + my $test = Test::PAUSE::Web->tests_for('user'); + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new; + my $res = $t->get("/authenquery/?ACTION=add_user");; + ok !$res->is_success; + is $res->code => HTTP_FORBIDDEN; +}; + +subtest 'disallowed action for a user' => sub { + my $test = Test::PAUSE::Web->tests_for('user'); + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my $res = $t->get("/authenquery/?ACTION=add_user");; + ok !$res->is_success; + is $res->code => HTTP_FORBIDDEN; +}; + +done_testing; diff --git a/t/pause_2025/lib/Test/PAUSE/MySQL.pm b/t/pause_2025/lib/Test/PAUSE/MySQL.pm new file mode 100644 index 000000000..8a298f343 --- /dev/null +++ b/t/pause_2025/lib/Test/PAUSE/MySQL.pm @@ -0,0 +1,242 @@ +package Test::PAUSE::MySQL; + +use Test::Builder (); +use Test::Requires qw(Test::mysqld); +use Test::Requires qw(File::Which); + +BEGIN { + unless (File::Which::which 'mysql') { + Test::Builder->new->skip_all("no mysql found, needed for this test") + } +} + +use Moose; +use Test::mysqld; +use Test::More; +use DBI; +use File::Temp qw/tempfile/; +use Capture::Tiny qw/capture_merged/; +use SQL::Maker; +use Path::Tiny; + +$SIG{INT} = sub { die "caught SIGINT, shutting down mysql\n" }; + +=head2 SYNOPSIS + + my $db + = Test::PAUSE::MySQL->new( schemas => ['doc/mod.schema.txt'] ); + + my $dbh = $db->dbh; + + # Drop straight in to the mysql console: + $dbh->debug_console + +=cut + +# These are the only caller-configurable parts + +# SQL to load at instantiation +has 'schemas' => ( + is => 'ro', + isa => 'ArrayRef[Str]', + default => sub {[]}, +); + +# Location of the mysql client binary +has 'mysql_client' => ( + is => 'ro', + isa => 'Str', + default => ($ENV{'PAUSE_MYSQL_CLIENT'} || 'mysql'), +); + +# These are the public methods + +# DBH +has 'dbh' => ( + is => 'ro', + isa => 'DBI::db', + lazy_build => 1, +); + +has 'sql_maker' => ( + is => 'ro', + isa => 'SQL::Maker', + lazy_build => 1, +); + +# Drops you in to `mysql` connected to the database +sub debug_console { + my $self = shift; + $self->run_mysql(); +} + +sub dsn { + my $self = shift; + return $self->mysqld->dsn( dbname => $self->_db_name ); +} + +# Private attributes + +# Object-specific database name +has '_db_name' => ( + is => 'ro', + isa => 'Str', + lazy_build => 1, +); + +sub _build__db_name { + my $self = shift; + return 'db_' . ( $self + 0 ) . int(rand 999_999); +} + +# Location of the config file for the mysql client +has '_auth_file' => ( + is => 'ro', + isa => 'Str', + lazy_build => 1, +); + +sub _build__auth_file { + my $self = shift; + my ($fh, $filename) = tempfile(); + my $args = $self->dsn; + $args =~ s/DBI:mysql://; + + my %options = map { split /=/ } split( /;/, $args ); + $options{'database'} = delete $options{'dbname'}; + $options{'socket'} = delete $options{'mysql_socket'}; + $options{'default-character-set'} = 'utf8'; + + my $auth_content = join "\n", "[client]", + map { "$_=" . $options{$_} } keys %options; + + print $fh $auth_content; + close $fh; + return $filename; +} + +sub BUILD { + my $self = shift; + my $dbh = $self->dbh; + + for my $schema ( @{$self->schemas} ) { + note("Loading schema: $schema"); + my $body = path($schema)->slurp; + for (grep $_, split /;\n/s, $body) { + $dbh->do($_); + } + } +} + + + +sub _build_dbh { + my $self = shift; + my $dbname = $self->_db_name; + + my $master_dbh = DBI->connect( + $self->mysqld->dsn( + dbname => 'test', + 'default-character-set' => 'utf8' + ) + ); + + note("Creating new MySQL database: $dbname"); + $master_dbh->do( 'CREATE DATABASE ' . $dbname ) + or die $master_dbh->errstr; + + # Connect to it + my $dbh = DBI->connect( $self->mysqld->dsn( dbname => $dbname ), + '', '', { RaiseError => 1 } ); + + return $dbh; +} + +sub _build_sql_maker { + my $self = shift; + SQL::Maker->new(driver => 'mysql'); +} + +sub run_mysql { + my $self = shift; + my $cmd = shift || ''; + my $exe = $self->mysql_client; + system(sprintf("%s --defaults-extra-file=%s %s", $exe, $self->_auth_file, $cmd)); +} + +# mysqld singleton. We might have different tests that want to execute in +# seperate DBs, but I can't see why we'd want to be running more than one +# mysqld, so we do a singleton here +our $mysqld; + +sub mysqld { + my $self = shift; + return $mysqld if $mysqld; + + note("Starting a test mysqld"); + note( + capture_merged( + sub { $mysqld = Test::mysqld->new( + my_cnf => { 'skip-networking' => '' } + ); + } + ) + ); + die $Test::mysqld::errstr unless $mysqld; + note("mysqld started"); + + return $mysqld; +} + +my %DefaultValues = ( + # authen_pause + # mod + packages => { + filemtime => time, + pause_reg => 'TESTUSER', + comment => '', + status => 'index', + }, + users => { + fullname => 'test', + homepage => '', + isa_list => '', + introduced => time, + changed => time, + changedby => 'TESTADMIN', + }, +); + +sub insert { + my ($self, $table, $values, $opt) = @_; + if (my $default = $DefaultValues{$table}) { + for my $key (keys %$default) { + $values->{$key} //= $default->{$key}; + } + } + if ($opt and delete $opt->{replace}) { + $opt->{prefix} = 'REPLACE'; + } + my ($sql, @bind) = $self->sql_maker->insert($table, $values, $opt); + $self->dbh->do($sql, undef, @bind); +} + +sub update { + my ($self, $table, $set, $where) = @_; + my ($sql, @bind) = $self->sql_maker->update($table, $set, $where); + $self->dbh->do($sql, undef, @bind); +} + +sub delete { + my ($self, $table, $where) = @_; + my ($sql, @bind) = $self->sql_maker->delete($table, $where); + $self->dbh->do($sql, undef, @bind); +} + +sub select { + my ($self, $table, $fields, $where, $opt) = @_; + my ($sql, @bind) = $self->sql_maker->select($table, $fields, $where, $opt); + $self->dbh->selectall_arrayref($sql, {Slice => +{}}, @bind); +} + +1; diff --git a/t/pause_2025/lib/Test/PAUSE/Web.pm b/t/pause_2025/lib/Test/PAUSE/Web.pm new file mode 100644 index 000000000..34b6338a1 --- /dev/null +++ b/t/pause_2025/lib/Test/PAUSE/Web.pm @@ -0,0 +1,464 @@ +package Test::PAUSE::Web; + +use strict; +use warnings; +use FindBin; +use JSON::PP; # just to avoid redefine warnings +use Path::Tiny; +use DBI; +use Plack::Test; +use Test::WWW::Mechanize::PSGI; +use Test::More; +use Exporter qw/import/; +use Test::PAUSE::MySQL; +use Email::Sender::Simple; +use Mojo::DOM; +use URI; +use URI::QueryParam; + +our $AppRoot = path(__FILE__)->parent->parent->parent->parent->parent->parent->realpath; +#our $AppRoot = path(__FILE__)->parent->parent->parent->parent->parent->parent->parent->realpath; +our $TmpDir = Path::Tiny->tempdir(TEMPLATE => "pause_web_XXXXXXXX"); +our $TestRoot = path($TmpDir)->realpath; +our $TestEmail = 'pause_admin@localhost.localdomain'; +our @EXPORT = @Test::More::EXPORT; + +our $FilenameToUpload = "Hash-RenameKey-0.02.tar.gz"; +our $FileToUpload = "$AppRoot/t/staging/$FilenameToUpload"; + +push @INC, "$AppRoot/lib", "$AppRoot/lib/pause_2017", "$AppRoot/privatelib"; + +$TmpDir->child($_)->mkpath for qw/rundata incoming etc public log/; +$TmpDir->child('log')->child('paused.log')->touch(); + +$INC{"PrivatePAUSE.pm"} = 1; +$ENV{EMAIL_SENDER_TRANSPORT} = "Test"; + +require PAUSE; +require PAUSE::Web::Config; + +$PAUSE::Config->{DOCUMENT_ROOT} = "$AppRoot/htdocs"; +$PAUSE::Config->{PID_DIR} = $TestRoot; +$PAUSE::Config->{ADMIN} = $TestEmail; +$PAUSE::Config->{ADMINS} = [$TestEmail]; +$PAUSE::Config->{CPAN_TESTERS} = $TestEmail; +$PAUSE::Config->{TO_CPAN_TESTERS} = $TestEmail; +$PAUSE::Config->{REPLY_TO_CPAN_TESTERS} = $TestEmail; +$PAUSE::Config->{GONERS_NOTIFY} = $TestEmail; +$PAUSE::Config->{P5P} = $TestEmail; +$PAUSE::Config->{MLROOT} = "$TestRoot/public/authors/id"; +$PAUSE::Config->{ML_CHOWN_USER} = 'ishigaki'; +$PAUSE::Config->{ML_CHOWN_GROUP} = 'ishigaki'; +$PAUSE::Config->{ML_MIN_INDEX_LINES} = 0; +$PAUSE::Config->{ML_MIN_FILES} = 0; +$PAUSE::Config->{RUNDATA} = "$TestRoot/rundata"; +$PAUSE::Config->{UPLOAD} = $TestEmail; +$PAUSE::Config->{HAVE_PERLBAL} = 0; +$PAUSE::Config->{SLEEP} = 1; +$PAUSE::Config->{INCOMING} = "file://$TestRoot/incoming/"; +$PAUSE::Config->{INCOMING_LOC} = "$TestRoot/incoming/"; +$PAUSE::Config->{PAUSE_LOG} = "$TestRoot/log/paused.log"; +$PAUSE::Config->{PAUSE_LOG_DIR} = "$TestRoot/log"; +$PAUSE::Config->{RECAPTCHA_ENABLED} = 0; + +# These will get changed every time you run setup() +$PAUSE::Config->{AUTHEN_DATA_SOURCE_NAME} = ""; +$PAUSE::Config->{MOD_DATA_SOURCE_NAME} = ""; + +$ENV{TEST_PAUSE_WEB} = 1; + +our $AuthDBH; +our $ModDBH; + +my $dbh_attr = {ShowErrorStatement => 1}; + +sub authen_dbh { $AuthDBH ||= authen_db()->dbh } +sub mod_dbh { $ModDBH ||= mod_db()->dbh } + +our $AuthDB; +sub authen_db { + my $db = $AuthDB ||= Test::PAUSE::MySQL->new( + schemas => ["$AppRoot/doc/authen_pause.schema.txt"] + ); + $PAUSE::Config->{AUTHEN_DATA_SOURCE_NAME} = $db->dsn; + $db; +} + +our $ModDB; +sub mod_db { + my $db = $ModDB ||= Test::PAUSE::MySQL->new( + schemas => ["$AppRoot/doc/mod.schema.txt"] + ); + $PAUSE::Config->{MOD_DATA_SOURCE_NAME} = $db->dsn; + $db; +} + +sub setup { # better to use Test::mysqld + my $class = shift; + + require PAUSE::Crypt; + + # Remove old DB handles and objects + undef $AuthDBH; + undef $AuthDB; + undef $ModDBH; + undef $ModDB; + + $class->reset_fixture; +} + +sub reset_fixture { + my $self = shift; + + # test fixture + { # authen_pause.usertable + $self->authen_dbh->do(qq{TRUNCATE usertable}); + for my $user ("TESTUSER", "TESTUSER2", "TESTUSER3", "TESTUSER4", "TESTADMIN", "TESTCNSRD") { + $self->authen_db->insert('usertable', { + user => $user, + password => PAUSE::Crypt::hash_password("test"), + secretemail => lc($user) . '@localhost', + }); + my $user_dir = join "/", $PAUSE::Config->{MLROOT}, PAUSE::user2dir($user); + path($user_dir)->mkpath; + } + } + { # authen_pause.grouptable + $self->authen_dbh->do(qq{TRUNCATE grouptable}); + $self->authen_db->insert('grouptable', {user => "TESTADMIN", ugroup => "admin"}); + } + { # mod.users + $self->mod_dbh->do(qq{TRUNCATE users}); + for my $user ("TESTUSER", "TESTUSER2", "TESTUSER3", "TESTUSER4", "TESTADMIN", "TESTCNSRD") { + $self->mod_db->insert('users', { + userid => $user, + fullname => "$user Name", + email => ($user eq "TESTCNSRD" ? "CENSORED" : (lc($user) . '@localhost')), + cpan_mail_alias => 'secr', + isa_list => '', + }); + } + } + $self; +} + +sub new { + my ($class, %args) = @_; + + my $psgi = $ENV{TEST_PAUSE_WEB_PSGI} // "app_2017.psgi"; + my $app = do "$AppRoot/$psgi"; + + $args{mech} = Test::WWW::Mechanize::PSGI->new(app => $app, cookie_jar => {}); + if (!$INC{'Devel/Cover.pm'} and !$ENV{TRAVIS} and $ENV{HARNESS_VERBOSE} and eval {require LWP::ConsoleLogger::Easy; 1}) { + LWP::ConsoleLogger::Easy::debug_ua($args{mech}); + } + $args{pass} ||= "test" if $args{user}; + + $class->clear_deliveries; + + bless \%args, $class; +} + +sub set_credentials { + my $self = shift; + note "log in as ".$self->{user}; + $self->{mech}->credentials($self->{user}, $self->{pass}); +} + +sub get { + my ($self, $url, @args) = @_; + + $self->set_credentials if $self->{user}; + if (@args and ref $args[0] eq 'HASH') { + my $params = shift @args; + $url = URI->new($url); + $url->query_param($_ => $params->{$_}) for keys %$params; + } + my $res = $self->{mech}->get($url, @args); + unlike $res->decoded_content => qr/(?:HASH|ARRAY|SCALAR|CODE)\(/; # most likely stringified reference + ok !grep /(?:HASH|ARRAY|SCALAR|CODE)\(/, map {$_->as_string} $self->deliveries; + $res; +} + +sub get_ok { + my ($self, $url, @args) = @_; + + $self->clear_deliveries; + my $res = $self->get($url, @args); + ok $res->is_success, "GET $url"; + $self->title_is_ok($url); + $self->note_deliveries; + $self; +} + +sub post { + my ($self, $url, @args) = @_; + + $self->set_credentials if $self->{user}; + my $res = $self->{mech}->post($url, @args); + unlike $res->decoded_content => qr/(?:HASH|ARRAY|SCALAR|CODE)\(/; # most likely stringified reference + ok !grep /(?:HASH|ARRAY|SCALAR|CODE)\(/, map {$_->as_string} $self->deliveries; + $res; +} + +sub post_ok { + my ($self, $url, @args) = @_; + + $self->clear_deliveries; + my $res = $self->post($url, @args); + ok $res->is_success, "POST $url"; + $self->title_is_ok($url); + $self->note_deliveries; + $self; +} + +sub post_with_token { + my ($self, $url, @args) = @_; + + my $res = $self->get($url); + return $res unless $res->is_success; + my $input = Mojo::DOM->new($res->decoded_content)->at('input[name="csrf_token"]'); + my $token = $input ? $input->attr('value') : ''; + ok $token, "Got a CSRF token"; + @args = {} if !@args; + $args[0]->{csrf_token} = $token if @args and ref $args[0] eq 'HASH'; + + $res = $self->post($url, @args); +} + +sub post_with_token_ok { + my ($self, $url, @args) = @_; + + $self->clear_deliveries; + my $res = $self->post_with_token($url, @args); + ok $res->is_success, "POST $url"; + $self->title_is_ok($url); + $self->note_deliveries; + $self; +} + +sub tests_for { + my ($self, $permission) = @_; + my @tests; + if ($permission eq "public") { + push @tests, ( + ["/pause/query"], + ["/pause/query", "TESTUSER"], + ["/pause/query", "TESTADMIN"], + ); + } + if ($permission ne "admin") { + push @tests, ["/pause/authenquery", "TESTUSER"]; + } + push @tests, ["/pause/authenquery", "TESTADMIN"]; + $ENV{PAUSE_WEB_TEST_ALL} && wantarray ? @tests : $tests[0]; +} + +sub content { + my $self = shift; + $self->{mech}->content; +} + +sub dom { + my $self = shift; + Mojo::DOM->new($self->content); +} + +sub text_is { + my ($self, $selector, $expects) = @_; + my $at = $self->dom->at($selector); + if ($at) { + my $text = $at->all_text // ''; + is $text => $expects, "$selector is $expects"; + } else { + fail "'$selector' is not found"; + } + $self; +} + +sub text_like { + my ($self, $selector, $expects) = @_; + my $at = $self->dom->at($selector); + if ($at) { + my $text = $at->all_text // ''; + like $text => $expects, "$selector like $expects"; + } else { + fail "'$selector' is not found"; + } + $self; +} + +sub text_unlike { + my ($self, $selector, $expects) = @_; + my $at = $self->dom->at($selector); + if ($at) { + my $text = $at->all_text // ''; + unlike $text => $expects, "$selector unlike $expects"; + } else { + fail "'$selector' is not found"; + } + $self; +} + +sub title_is_ok { + my ($self, $url) = @_; + return if $self->dom->at('p.error_message'); # ignore if error + return if $self->{mech}->content_type !~ /html/i; + + my ($action) = $url =~ /ACTION=(\w+)/; + $action ||= $url; # in case action is passed as url + return if $action =~ /^select_(user|ml_action)$/; + my $conf = PAUSE::Web::Config->action($action); + return if $conf->{has_title}; # uses different title from its data source + + my $title = $conf->{verb}; + return unless $title; # maybe top page + + $self->text_is("h2.firstheader", $title); +} + +sub file_to_upload { + wantarray ? ($FileToUpload, $FilenameToUpload) : $FileToUpload; +} + +sub copy_to_authors_dir { + my ($self, $user, $file) = @_; + my $userhome = PAUSE::user2dir($user); + my $destination = path("$PAUSE::Config->{MLROOT}/$userhome"); + $destination->mkpath; + note "copy $file to $destination"; + path($file)->copy($destination); +} + +sub save_to_authors_dir { + my ($self, $user, $file, $body) = @_; + my $userhome = PAUSE::user2dir($user); + my $destination = path("$PAUSE::Config->{MLROOT}/$userhome"); + $destination->mkpath; + note "save $file to $destination"; + path("$destination/$file")->spew($body); +} + +sub remove_authors_dir { + my ($self, $user) = @_; + my $userhome = PAUSE::user2dir($user); + my $destination = path("$PAUSE::Config->{MLROOT}/$userhome"); + $destination->remove_tree; +} + +sub deliveries { map { $_->{email}->cast('Email::MIME') } Email::Sender::Simple->default_transport->deliveries } +sub clear_deliveries { Email::Sender::Simple->default_transport->clear_deliveries } +sub note_deliveries { note "-- email begin --\n".$_->as_string."\n-- email end --\n\n" for shift->deliveries } + +END { $TmpDir->remove_tree if $TmpDir } + +sub reset_module_fixture { + my $self = shift; + + $self->mod_dbh->do("TRUNCATE primeur"); + $self->mod_dbh->do("TRUNCATE perms"); + $self->mod_dbh->do("TRUNCATE packages"); + + my @dists = ( + { + name => 'Module-Admin', + owner => 'TESTADMIN', + packages => [qw/ + Module::Admin::Foo + Module::Admin::Bar + /], + comaints => [qw/TESTUSER2/], + }, + { + name => 'Module-User', + owner => 'TESTUSER', + packages => [qw/ + Module::User::Foo + Module::User::Bar + /], + comaints => [ + [TESTADMIN => [qw/Module::User::Foo/]], + [TESTUSER2 => [qw/Module::User::Bar/]], + ], + }, + { + name => 'Module-User-Foo-Baz', + owner => 'TESTUSER', + packages => [qw/ + Module::User::Foo::Baz + /], + }, + { + name => 'Module-Comaint', + owner => 'TESTUSER2', + packages => [qw/ + Module::Comaint + Module::Comaint::Foo + /], + comaints => [qw/TESTADMIN TESTUSER/], + }, + { + name => 'Module-Managed', + owner => 'TESTUSER2', + packages => [qw/ + Module::Managed + Module::Managed::Foo + /], + comaints => [ + [TESTUSER3 => [qw/Module::Managed/]], + ], + }, + { + name => 'Module-Unrelated', + owner => 'TESTUSER3', + packages => [qw/ + Module::Unrelated + Module::Unrelated::Foo + /], + }, + ); + + for my $dist (@dists) { + for my $package (@{$dist->{packages}}) { + my $userdir = _userdir($dist->{owner}); + $self->mod_db->insert("packages", { + package => $package, + version => '0.01', + dist => "$userdir/$dist->{name}-0.01.tar.gz", + distname => $dist->{name}, + filemtime => time, + pause_reg => time, + status => 'index', + }); + $self->mod_db->insert("primeur", { + package => $package, + userid => $dist->{owner}, + }); + } + for my $comaint (@{$dist->{comaints} // []}) { + if (ref $comaint eq 'ARRAY') { + my ($id, $packages) = @$comaint; + for my $package (@$packages) { + $self->mod_db->insert("perms", { + package => $package, + userid => $id, + }); + } + } else { + for my $package (@{$dist->{packages}}) { + $self->mod_db->insert("perms", { + package => $package, + userid => $comaint, + }); + } + } + } + } +} + +sub _userdir { + my $user = shift; + join '/', substr($user, 0, 1), substr($user, 0, 2), $user; +} + +1; diff --git a/t/pause_2025/logout.t b/t/pause_2025/logout.t new file mode 100644 index 000000000..e3e4b92ed --- /dev/null +++ b/t/pause_2025/logout.t @@ -0,0 +1,44 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/lib"; +use Test::PAUSE::Web; +use utf8; +use HTTP::Status qw/:constants/; + +Test::PAUSE::Web->setup; + +subtest 'logout 1: redirect with Cookie' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $rand = rand 1; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path"); + my $res = $t->get("$path?logout=1$rand"); + is $res->code => HTTP_UNAUTHORIZED; + } +}; + +subtest 'logout 2: redirect to Badname:Badpass@Server URL' => sub { + plan skip_all => "WWW::Mechanize/LWP::UserAgent currently ignores userinfo"; + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $rand = rand 1; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path"); + my $res = $t->get("$path?logout=2$rand"); + is $res->code => HTTP_UNAUTHORIZED; + } +}; + +subtest 'logout 3: Quick direct 401' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $rand = rand 1; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path"); + my $res = $t->get("$path?logout=3$rand"); + is $res->code => HTTP_UNAUTHORIZED; + } +}; + +done_testing; From 6bfdf9d98f39c5434ec0c9a4d2ac4fa93984c787 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Thu, 1 May 2025 23:22:27 +0900 Subject: [PATCH 41/51] Rename t/pause_2025/action as t/pause_2025/action_2017 as the current tests under action expects things work the same as app_2017. (We'll add action_2025 next) --- t/pause_2025/{action => action_2017}/add_uri.t | 0 t/pause_2025/{action => action_2017}/add_user.t | 0 t/pause_2025/{action => action_2017}/change_passwd.t | 0 t/pause_2025/{action => action_2017}/delete_files.t | 0 t/pause_2025/{action => action_2017}/edit_cred.t | 0 t/pause_2025/{action => action_2017}/edit_ml.t | 0 t/pause_2025/{action => action_2017}/edit_uris.t | 0 t/pause_2025/{action => action_2017}/email_for_admin.t | 0 t/pause_2025/{action => action_2017}/giveup_comaint.t | 0 t/pause_2025/{action => action_2017}/giveup_dist_comaint.t | 0 t/pause_2025/{action => action_2017}/mailpw.t | 0 t/pause_2025/{action => action_2017}/make_comaint.t | 0 t/pause_2025/{action => action_2017}/make_dist_comaint.t | 0 t/pause_2025/{action => action_2017}/manage_id_requests.t | 0 t/pause_2025/{action => action_2017}/move_dist_primary.t | 0 t/pause_2025/{action => action_2017}/move_primary.t | 0 t/pause_2025/{action => action_2017}/pause_04about.t | 0 t/pause_2025/{action => action_2017}/pause_04imprint.t | 0 t/pause_2025/{action => action_2017}/pause_05news.t | 0 t/pause_2025/{action => action_2017}/pause_06history.t | 0 t/pause_2025/{action => action_2017}/pause_logout.t | 0 t/pause_2025/{action => action_2017}/pause_namingmodules.t | 0 t/pause_2025/{action => action_2017}/pause_operating_model.t | 0 t/pause_2025/{action => action_2017}/pause_privacy_policy.t | 0 t/pause_2025/{action => action_2017}/peek_dist_perms.t | 0 t/pause_2025/{action => action_2017}/peek_perms.t | 0 t/pause_2025/{action => action_2017}/reindex.t | 0 t/pause_2025/{action => action_2017}/remove_comaint.t | 0 t/pause_2025/{action => action_2017}/remove_dist_comaint.t | 0 t/pause_2025/{action => action_2017}/remove_dist_primary.t | 0 t/pause_2025/{action => action_2017}/remove_primary.t | 0 t/pause_2025/{action => action_2017}/request_id.t | 0 t/pause_2025/{action => action_2017}/reset_version.t | 0 t/pause_2025/{action => action_2017}/select_ml_action.t | 0 t/pause_2025/{action => action_2017}/select_user.t | 0 t/pause_2025/{action => action_2017}/share_perms.t | 0 t/pause_2025/{action => action_2017}/show_files.t | 0 t/pause_2025/{action => action_2017}/show_ml_repr.t | 0 t/pause_2025/{action => action_2017}/tail_logfile.t | 0 t/pause_2025/{action => action_2017}/who_admin.t | 0 t/pause_2025/{action => action_2017}/who_pumpkin.t | 0 41 files changed, 0 insertions(+), 0 deletions(-) rename t/pause_2025/{action => action_2017}/add_uri.t (100%) rename t/pause_2025/{action => action_2017}/add_user.t (100%) rename t/pause_2025/{action => action_2017}/change_passwd.t (100%) rename t/pause_2025/{action => action_2017}/delete_files.t (100%) rename t/pause_2025/{action => action_2017}/edit_cred.t (100%) rename t/pause_2025/{action => action_2017}/edit_ml.t (100%) rename t/pause_2025/{action => action_2017}/edit_uris.t (100%) rename t/pause_2025/{action => action_2017}/email_for_admin.t (100%) rename t/pause_2025/{action => action_2017}/giveup_comaint.t (100%) rename t/pause_2025/{action => action_2017}/giveup_dist_comaint.t (100%) rename t/pause_2025/{action => action_2017}/mailpw.t (100%) rename t/pause_2025/{action => action_2017}/make_comaint.t (100%) rename t/pause_2025/{action => action_2017}/make_dist_comaint.t (100%) rename t/pause_2025/{action => action_2017}/manage_id_requests.t (100%) rename t/pause_2025/{action => action_2017}/move_dist_primary.t (100%) rename t/pause_2025/{action => action_2017}/move_primary.t (100%) rename t/pause_2025/{action => action_2017}/pause_04about.t (100%) rename t/pause_2025/{action => action_2017}/pause_04imprint.t (100%) rename t/pause_2025/{action => action_2017}/pause_05news.t (100%) rename t/pause_2025/{action => action_2017}/pause_06history.t (100%) rename t/pause_2025/{action => action_2017}/pause_logout.t (100%) rename t/pause_2025/{action => action_2017}/pause_namingmodules.t (100%) rename t/pause_2025/{action => action_2017}/pause_operating_model.t (100%) rename t/pause_2025/{action => action_2017}/pause_privacy_policy.t (100%) rename t/pause_2025/{action => action_2017}/peek_dist_perms.t (100%) rename t/pause_2025/{action => action_2017}/peek_perms.t (100%) rename t/pause_2025/{action => action_2017}/reindex.t (100%) rename t/pause_2025/{action => action_2017}/remove_comaint.t (100%) rename t/pause_2025/{action => action_2017}/remove_dist_comaint.t (100%) rename t/pause_2025/{action => action_2017}/remove_dist_primary.t (100%) rename t/pause_2025/{action => action_2017}/remove_primary.t (100%) rename t/pause_2025/{action => action_2017}/request_id.t (100%) rename t/pause_2025/{action => action_2017}/reset_version.t (100%) rename t/pause_2025/{action => action_2017}/select_ml_action.t (100%) rename t/pause_2025/{action => action_2017}/select_user.t (100%) rename t/pause_2025/{action => action_2017}/share_perms.t (100%) rename t/pause_2025/{action => action_2017}/show_files.t (100%) rename t/pause_2025/{action => action_2017}/show_ml_repr.t (100%) rename t/pause_2025/{action => action_2017}/tail_logfile.t (100%) rename t/pause_2025/{action => action_2017}/who_admin.t (100%) rename t/pause_2025/{action => action_2017}/who_pumpkin.t (100%) diff --git a/t/pause_2025/action/add_uri.t b/t/pause_2025/action_2017/add_uri.t similarity index 100% rename from t/pause_2025/action/add_uri.t rename to t/pause_2025/action_2017/add_uri.t diff --git a/t/pause_2025/action/add_user.t b/t/pause_2025/action_2017/add_user.t similarity index 100% rename from t/pause_2025/action/add_user.t rename to t/pause_2025/action_2017/add_user.t diff --git a/t/pause_2025/action/change_passwd.t b/t/pause_2025/action_2017/change_passwd.t similarity index 100% rename from t/pause_2025/action/change_passwd.t rename to t/pause_2025/action_2017/change_passwd.t diff --git a/t/pause_2025/action/delete_files.t b/t/pause_2025/action_2017/delete_files.t similarity index 100% rename from t/pause_2025/action/delete_files.t rename to t/pause_2025/action_2017/delete_files.t diff --git a/t/pause_2025/action/edit_cred.t b/t/pause_2025/action_2017/edit_cred.t similarity index 100% rename from t/pause_2025/action/edit_cred.t rename to t/pause_2025/action_2017/edit_cred.t diff --git a/t/pause_2025/action/edit_ml.t b/t/pause_2025/action_2017/edit_ml.t similarity index 100% rename from t/pause_2025/action/edit_ml.t rename to t/pause_2025/action_2017/edit_ml.t diff --git a/t/pause_2025/action/edit_uris.t b/t/pause_2025/action_2017/edit_uris.t similarity index 100% rename from t/pause_2025/action/edit_uris.t rename to t/pause_2025/action_2017/edit_uris.t diff --git a/t/pause_2025/action/email_for_admin.t b/t/pause_2025/action_2017/email_for_admin.t similarity index 100% rename from t/pause_2025/action/email_for_admin.t rename to t/pause_2025/action_2017/email_for_admin.t diff --git a/t/pause_2025/action/giveup_comaint.t b/t/pause_2025/action_2017/giveup_comaint.t similarity index 100% rename from t/pause_2025/action/giveup_comaint.t rename to t/pause_2025/action_2017/giveup_comaint.t diff --git a/t/pause_2025/action/giveup_dist_comaint.t b/t/pause_2025/action_2017/giveup_dist_comaint.t similarity index 100% rename from t/pause_2025/action/giveup_dist_comaint.t rename to t/pause_2025/action_2017/giveup_dist_comaint.t diff --git a/t/pause_2025/action/mailpw.t b/t/pause_2025/action_2017/mailpw.t similarity index 100% rename from t/pause_2025/action/mailpw.t rename to t/pause_2025/action_2017/mailpw.t diff --git a/t/pause_2025/action/make_comaint.t b/t/pause_2025/action_2017/make_comaint.t similarity index 100% rename from t/pause_2025/action/make_comaint.t rename to t/pause_2025/action_2017/make_comaint.t diff --git a/t/pause_2025/action/make_dist_comaint.t b/t/pause_2025/action_2017/make_dist_comaint.t similarity index 100% rename from t/pause_2025/action/make_dist_comaint.t rename to t/pause_2025/action_2017/make_dist_comaint.t diff --git a/t/pause_2025/action/manage_id_requests.t b/t/pause_2025/action_2017/manage_id_requests.t similarity index 100% rename from t/pause_2025/action/manage_id_requests.t rename to t/pause_2025/action_2017/manage_id_requests.t diff --git a/t/pause_2025/action/move_dist_primary.t b/t/pause_2025/action_2017/move_dist_primary.t similarity index 100% rename from t/pause_2025/action/move_dist_primary.t rename to t/pause_2025/action_2017/move_dist_primary.t diff --git a/t/pause_2025/action/move_primary.t b/t/pause_2025/action_2017/move_primary.t similarity index 100% rename from t/pause_2025/action/move_primary.t rename to t/pause_2025/action_2017/move_primary.t diff --git a/t/pause_2025/action/pause_04about.t b/t/pause_2025/action_2017/pause_04about.t similarity index 100% rename from t/pause_2025/action/pause_04about.t rename to t/pause_2025/action_2017/pause_04about.t diff --git a/t/pause_2025/action/pause_04imprint.t b/t/pause_2025/action_2017/pause_04imprint.t similarity index 100% rename from t/pause_2025/action/pause_04imprint.t rename to t/pause_2025/action_2017/pause_04imprint.t diff --git a/t/pause_2025/action/pause_05news.t b/t/pause_2025/action_2017/pause_05news.t similarity index 100% rename from t/pause_2025/action/pause_05news.t rename to t/pause_2025/action_2017/pause_05news.t diff --git a/t/pause_2025/action/pause_06history.t b/t/pause_2025/action_2017/pause_06history.t similarity index 100% rename from t/pause_2025/action/pause_06history.t rename to t/pause_2025/action_2017/pause_06history.t diff --git a/t/pause_2025/action/pause_logout.t b/t/pause_2025/action_2017/pause_logout.t similarity index 100% rename from t/pause_2025/action/pause_logout.t rename to t/pause_2025/action_2017/pause_logout.t diff --git a/t/pause_2025/action/pause_namingmodules.t b/t/pause_2025/action_2017/pause_namingmodules.t similarity index 100% rename from t/pause_2025/action/pause_namingmodules.t rename to t/pause_2025/action_2017/pause_namingmodules.t diff --git a/t/pause_2025/action/pause_operating_model.t b/t/pause_2025/action_2017/pause_operating_model.t similarity index 100% rename from t/pause_2025/action/pause_operating_model.t rename to t/pause_2025/action_2017/pause_operating_model.t diff --git a/t/pause_2025/action/pause_privacy_policy.t b/t/pause_2025/action_2017/pause_privacy_policy.t similarity index 100% rename from t/pause_2025/action/pause_privacy_policy.t rename to t/pause_2025/action_2017/pause_privacy_policy.t diff --git a/t/pause_2025/action/peek_dist_perms.t b/t/pause_2025/action_2017/peek_dist_perms.t similarity index 100% rename from t/pause_2025/action/peek_dist_perms.t rename to t/pause_2025/action_2017/peek_dist_perms.t diff --git a/t/pause_2025/action/peek_perms.t b/t/pause_2025/action_2017/peek_perms.t similarity index 100% rename from t/pause_2025/action/peek_perms.t rename to t/pause_2025/action_2017/peek_perms.t diff --git a/t/pause_2025/action/reindex.t b/t/pause_2025/action_2017/reindex.t similarity index 100% rename from t/pause_2025/action/reindex.t rename to t/pause_2025/action_2017/reindex.t diff --git a/t/pause_2025/action/remove_comaint.t b/t/pause_2025/action_2017/remove_comaint.t similarity index 100% rename from t/pause_2025/action/remove_comaint.t rename to t/pause_2025/action_2017/remove_comaint.t diff --git a/t/pause_2025/action/remove_dist_comaint.t b/t/pause_2025/action_2017/remove_dist_comaint.t similarity index 100% rename from t/pause_2025/action/remove_dist_comaint.t rename to t/pause_2025/action_2017/remove_dist_comaint.t diff --git a/t/pause_2025/action/remove_dist_primary.t b/t/pause_2025/action_2017/remove_dist_primary.t similarity index 100% rename from t/pause_2025/action/remove_dist_primary.t rename to t/pause_2025/action_2017/remove_dist_primary.t diff --git a/t/pause_2025/action/remove_primary.t b/t/pause_2025/action_2017/remove_primary.t similarity index 100% rename from t/pause_2025/action/remove_primary.t rename to t/pause_2025/action_2017/remove_primary.t diff --git a/t/pause_2025/action/request_id.t b/t/pause_2025/action_2017/request_id.t similarity index 100% rename from t/pause_2025/action/request_id.t rename to t/pause_2025/action_2017/request_id.t diff --git a/t/pause_2025/action/reset_version.t b/t/pause_2025/action_2017/reset_version.t similarity index 100% rename from t/pause_2025/action/reset_version.t rename to t/pause_2025/action_2017/reset_version.t diff --git a/t/pause_2025/action/select_ml_action.t b/t/pause_2025/action_2017/select_ml_action.t similarity index 100% rename from t/pause_2025/action/select_ml_action.t rename to t/pause_2025/action_2017/select_ml_action.t diff --git a/t/pause_2025/action/select_user.t b/t/pause_2025/action_2017/select_user.t similarity index 100% rename from t/pause_2025/action/select_user.t rename to t/pause_2025/action_2017/select_user.t diff --git a/t/pause_2025/action/share_perms.t b/t/pause_2025/action_2017/share_perms.t similarity index 100% rename from t/pause_2025/action/share_perms.t rename to t/pause_2025/action_2017/share_perms.t diff --git a/t/pause_2025/action/show_files.t b/t/pause_2025/action_2017/show_files.t similarity index 100% rename from t/pause_2025/action/show_files.t rename to t/pause_2025/action_2017/show_files.t diff --git a/t/pause_2025/action/show_ml_repr.t b/t/pause_2025/action_2017/show_ml_repr.t similarity index 100% rename from t/pause_2025/action/show_ml_repr.t rename to t/pause_2025/action_2017/show_ml_repr.t diff --git a/t/pause_2025/action/tail_logfile.t b/t/pause_2025/action_2017/tail_logfile.t similarity index 100% rename from t/pause_2025/action/tail_logfile.t rename to t/pause_2025/action_2017/tail_logfile.t diff --git a/t/pause_2025/action/who_admin.t b/t/pause_2025/action_2017/who_admin.t similarity index 100% rename from t/pause_2025/action/who_admin.t rename to t/pause_2025/action_2017/who_admin.t diff --git a/t/pause_2025/action/who_pumpkin.t b/t/pause_2025/action_2017/who_pumpkin.t similarity index 100% rename from t/pause_2025/action/who_pumpkin.t rename to t/pause_2025/action_2017/who_pumpkin.t From a86b9e4b01908a0ead808105ad533314b0d32b00 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Thu, 1 May 2025 23:25:43 +0900 Subject: [PATCH 42/51] Copy tests under t/pause_2025/action_2017 to t/pause_2025/action_2025 --- t/pause_2025/action_2025/add_uri.t | 296 ++++++++++++++++++ t/pause_2025/action_2025/add_user.t | 276 ++++++++++++++++ t/pause_2025/action_2025/change_passwd.t | 227 ++++++++++++++ t/pause_2025/action_2025/delete_files.t | 244 +++++++++++++++ t/pause_2025/action_2025/edit_cred.t | 65 ++++ t/pause_2025/action_2025/edit_ml.t | 18 ++ t/pause_2025/action_2025/edit_uris.t | 45 +++ t/pause_2025/action_2025/email_for_admin.t | 18 ++ t/pause_2025/action_2025/giveup_comaint.t | 112 +++++++ .../action_2025/giveup_dist_comaint.t | 109 +++++++ t/pause_2025/action_2025/mailpw.t | 175 +++++++++++ t/pause_2025/action_2025/make_comaint.t | 170 ++++++++++ t/pause_2025/action_2025/make_dist_comaint.t | 165 ++++++++++ t/pause_2025/action_2025/manage_id_requests.t | 18 ++ t/pause_2025/action_2025/move_dist_primary.t | 161 ++++++++++ t/pause_2025/action_2025/move_primary.t | 168 ++++++++++ t/pause_2025/action_2025/pause_04about.t | 18 ++ t/pause_2025/action_2025/pause_04imprint.t | 18 ++ t/pause_2025/action_2025/pause_05news.t | 18 ++ t/pause_2025/action_2025/pause_06history.t | 18 ++ t/pause_2025/action_2025/pause_logout.t | 18 ++ .../action_2025/pause_namingmodules.t | 18 ++ .../action_2025/pause_operating_model.t | 18 ++ .../action_2025/pause_privacy_policy.t | 18 ++ t/pause_2025/action_2025/peek_dist_perms.t | 172 ++++++++++ t/pause_2025/action_2025/peek_perms.t | 240 ++++++++++++++ t/pause_2025/action_2025/reindex.t | 47 +++ t/pause_2025/action_2025/remove_comaint.t | 172 ++++++++++ .../action_2025/remove_dist_comaint.t | 166 ++++++++++ .../action_2025/remove_dist_primary.t | 134 ++++++++ t/pause_2025/action_2025/remove_primary.t | 138 ++++++++ t/pause_2025/action_2025/request_id.t | 273 ++++++++++++++++ t/pause_2025/action_2025/reset_version.t | 48 +++ t/pause_2025/action_2025/select_ml_action.t | 49 +++ t/pause_2025/action_2025/select_user.t | 18 ++ t/pause_2025/action_2025/share_perms.t | 18 ++ t/pause_2025/action_2025/show_files.t | 18 ++ t/pause_2025/action_2025/show_ml_repr.t | 18 ++ t/pause_2025/action_2025/tail_logfile.t | 43 +++ t/pause_2025/action_2025/who_admin.t | 44 +++ t/pause_2025/action_2025/who_pumpkin.t | 44 +++ 41 files changed, 4053 insertions(+) create mode 100644 t/pause_2025/action_2025/add_uri.t create mode 100644 t/pause_2025/action_2025/add_user.t create mode 100644 t/pause_2025/action_2025/change_passwd.t create mode 100644 t/pause_2025/action_2025/delete_files.t create mode 100644 t/pause_2025/action_2025/edit_cred.t create mode 100644 t/pause_2025/action_2025/edit_ml.t create mode 100644 t/pause_2025/action_2025/edit_uris.t create mode 100644 t/pause_2025/action_2025/email_for_admin.t create mode 100644 t/pause_2025/action_2025/giveup_comaint.t create mode 100644 t/pause_2025/action_2025/giveup_dist_comaint.t create mode 100644 t/pause_2025/action_2025/mailpw.t create mode 100644 t/pause_2025/action_2025/make_comaint.t create mode 100644 t/pause_2025/action_2025/make_dist_comaint.t create mode 100644 t/pause_2025/action_2025/manage_id_requests.t create mode 100644 t/pause_2025/action_2025/move_dist_primary.t create mode 100644 t/pause_2025/action_2025/move_primary.t create mode 100644 t/pause_2025/action_2025/pause_04about.t create mode 100644 t/pause_2025/action_2025/pause_04imprint.t create mode 100644 t/pause_2025/action_2025/pause_05news.t create mode 100644 t/pause_2025/action_2025/pause_06history.t create mode 100644 t/pause_2025/action_2025/pause_logout.t create mode 100644 t/pause_2025/action_2025/pause_namingmodules.t create mode 100644 t/pause_2025/action_2025/pause_operating_model.t create mode 100644 t/pause_2025/action_2025/pause_privacy_policy.t create mode 100644 t/pause_2025/action_2025/peek_dist_perms.t create mode 100644 t/pause_2025/action_2025/peek_perms.t create mode 100644 t/pause_2025/action_2025/reindex.t create mode 100644 t/pause_2025/action_2025/remove_comaint.t create mode 100644 t/pause_2025/action_2025/remove_dist_comaint.t create mode 100644 t/pause_2025/action_2025/remove_dist_primary.t create mode 100644 t/pause_2025/action_2025/remove_primary.t create mode 100644 t/pause_2025/action_2025/request_id.t create mode 100644 t/pause_2025/action_2025/reset_version.t create mode 100644 t/pause_2025/action_2025/select_ml_action.t create mode 100644 t/pause_2025/action_2025/select_user.t create mode 100644 t/pause_2025/action_2025/share_perms.t create mode 100644 t/pause_2025/action_2025/show_files.t create mode 100644 t/pause_2025/action_2025/show_ml_repr.t create mode 100644 t/pause_2025/action_2025/tail_logfile.t create mode 100644 t/pause_2025/action_2025/who_admin.t create mode 100644 t/pause_2025/action_2025/who_pumpkin.t diff --git a/t/pause_2025/action_2025/add_uri.t b/t/pause_2025/action_2025/add_uri.t new file mode 100644 index 000000000..5d1c22f66 --- /dev/null +++ b/t/pause_2025/action_2025/add_uri.t @@ -0,0 +1,296 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use File::Path qw/rmtree mkpath/; +use File::Spec; +use Mojo::File qw/path/; +use utf8; + +my $http_upload = { + pause99_add_uri_httpupload => ["$Test::PAUSE::Web::AppRoot/htdocs/index.html", "index.html"], + SUBMIT_pause99_add_uri_httpupload => 1, +}; + +my $uri_upload = { + pause99_add_uri_uri => "file://".File::Spec->rel2abs(__FILE__), + SUBMIT_pause99_add_uri_uri => 1, +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=add_uri"); + # note $t->content; + } +}; + +subtest 'get: user with subdirs' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $user_home = $PAUSE::Config->{MLROOT}."/".PAUSE::user2dir($user); + my $subdir = path("$user_home/test"); + $subdir->make_path; + $subdir->child("stuff.txt")->spew("Foo"); + + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=add_uri"); + $t->text_is('select[name="pause99_add_uri_subdirscrl"] option[value="."]', "."); # default + $t->text_is('select[name="pause99_add_uri_subdirscrl"] option[value="test"]', "test"); + # note $t->content; + } +}; + +subtest 'post: basic' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$http_upload; + my $file = $PAUSE::Config->{INCOMING_LOC}."/".$form{pause99_add_uri_httpupload}[1]; + ok !-f $file, "file to upload does not exist"; + + $t->mod_dbh->do('TRUNCATE uris'); + $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + # note $t->content; + + ok -f $file, "uploaded file exists"; + unlink $file; + + my $rows = $t->mod_db->select('uris', ['*'], { + userid => $user, + uri => $form{pause99_add_uri_httpupload}[1], + }); + is @$rows => 1; + } +}; + +subtest 'post: under a new subdir' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$http_upload; + $form{pause99_add_uri_subdirtext} = "new_dir"; + + my $file = $PAUSE::Config->{INCOMING_LOC}."/".$form{pause99_add_uri_httpupload}[1]; + ok !-f $file, "file to upload does not exist"; + + $t->mod_dbh->do('TRUNCATE uris'); + $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + # note $t->content; + + ok -f $file, "uploaded file exists"; + unlink $file; + + my $rows = $t->mod_db->select('uris', ['*'], { + userid => $user, + uri => $form{pause99_add_uri_httpupload}[1], + }); + is @$rows => 1; + like $rows->[0]{uriid} => qr!/new_dir/!, "uriid contains /new_dir/"; + } +}; + +subtest 'post: under a Perl6 subdir' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$http_upload; + $form{pause99_add_uri_subdirscrl} = "Perl6"; + + my $user_home = $PAUSE::Config->{MLROOT}."/".PAUSE::user2dir($user); + my $subdir = path("$user_home/Perl6"); + $subdir->make_path; + $subdir->child("stuff.txt")->spew("Foo"); + + my $file = $PAUSE::Config->{INCOMING_LOC}."/".$form{pause99_add_uri_httpupload}[1]; + ok !-f $file, "file to upload does not exist"; + + $t->mod_dbh->do('TRUNCATE uris'); + $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + # note $t->content; + + ok -f $file, "uploaded file exists"; + unlink $file; + + my $rows = $t->mod_db->select('uris', ['*'], { + userid => $user, + uri => $form{pause99_add_uri_httpupload}[1], + }); + is @$rows => 1; + like $rows->[0]{uriid} => qr!/Perl6/!, "uriid contains /Perl6/"; + ok $rows->[0]{is_perl6}; + } +}; + +subtest 'post: empty' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$http_upload; + $form{pause99_add_uri_httpupload} = [undef, 'index.html']; + + $t->mod_dbh->do('TRUNCATE uris'); + $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + # note $t->content; + + my $rows = $t->mod_db->select('uris', ['*'], { + userid => $user, + uri => $form{pause99_add_uri_httpupload}[1], + }); + is @$rows => 0; + } +}; + +subtest 'post: renamed' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$http_upload; + $form{pause99_add_uri_httpupload} = ["$Test::PAUSE::Web::AppRoot/htdocs/index.html", 'html/index.html']; + my $file = $PAUSE::Config->{INCOMING_LOC}."/index.html"; + ok !-f $file, "file to upload does not exist"; + + $t->mod_dbh->do('TRUNCATE uris'); + $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + # note $t->content; + + # renamed file exists + ok -f $file, "uploaded file exists"; + unlink $file; + + my $rows = $t->mod_db->select('uris', ['*'], { + userid => $user, + uri => "index.html", + }); + is @$rows => 1; + } +}; + +subtest 'post: uri' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$uri_upload; + + $t->mod_dbh->do('TRUNCATE uris'); + $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + # note $t->content; + + my $rows = $t->mod_db->select('uris', ['*'], { + userid => $user, + uri => $form{pause99_add_uri_uri}, + }); + is @$rows => 1; + } +}; + +subtest 'post: CHECKSUMS' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$http_upload; + $form{pause99_add_uri_httpupload} = ["$Test::PAUSE::Web::AppRoot/htdocs/index.html", "CHECKSUMS"], + + $t->mod_dbh->do('TRUNCATE uris'); + $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + $t->text_like('.error_message' => qr/Files with the name CHECKSUMS cannot be/); + # note $t->content; + + my $rows = $t->mod_db->select('uris', ['*'], { + userid => $user, + uri => $form{pause99_add_uri_httpupload}[1], + }); + is @$rows => 0; + } +}; + +subtest 'post: allow overwrite' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$http_upload; + my $file = $PAUSE::Config->{INCOMING_LOC}."/".$form{pause99_add_uri_httpupload}[1]; + ok !-f $file, "file to upload does not exists"; + + $t->mod_dbh->do('TRUNCATE uris'); + for (0 .. 1) { + $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + # note $t->content; + + # uploaded file exists + ok -f $file, "uploaded file exists"; + unlink $file; + } + + my $rows = $t->mod_db->select('uris', ['*'], { + userid => $user, + uri => $form{pause99_add_uri_httpupload}[1], + }); + is @$rows => 1; + } +}; + +subtest 'post: duplicate' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$http_upload; + $form{pause99_add_uri_httpupload} = ["$Test::PAUSE::Web::AppRoot/htdocs/index.html", "index.tar.gz"], + my $file = $PAUSE::Config->{INCOMING_LOC}."/".$form{pause99_add_uri_httpupload}[1]; + ok !-f $file, "file to upload does not exist"; + + $t->mod_dbh->do('TRUNCATE uris'); + $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + # note $t->content; + + ok -f $file, "uploaded file exists"; + unlink $file; + + my $rows = $t->mod_db->select('uris', ['*'], { + userid => $user, + uri => $form{pause99_add_uri_httpupload}[1], + }); + is @$rows => 1; + + my $res = $t->post("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + is $res->code => 409; + # note $t->content; + + ok -f $file, "uploaded file exists"; + unlink $file; + + $rows = $t->mod_db->select('uris', ['*'], { + userid => $user, + uri => $form{pause99_add_uri_httpupload}[1], + }); + is @$rows => 1; + } +}; + +subtest 'post: to the site top, as various CPAN uploaders do/did' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$http_upload; + my $file = $PAUSE::Config->{INCOMING_LOC}."/".$form{pause99_add_uri_httpupload}[1]; + ok !-f $file, "file to upload does not exist"; + + $t->mod_dbh->do('TRUNCATE uris'); + $t->post_ok("$path", \%form, "Content-Type" => "form-data"); + # note $t->content; + + ok -f $file, "uploaded file exists"; + unlink $file; + + my $rows = $t->mod_db->select('uris', ['*'], { + userid => $user, + uri => $form{pause99_add_uri_httpupload}[1], + }); + is @$rows => 1; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/add_user.t b/t/pause_2025/action_2025/add_user.t new file mode 100644 index 000000000..0912d03a3 --- /dev/null +++ b/t/pause_2025/action_2025/add_user.t @@ -0,0 +1,276 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +my $new_user = { + SUBMIT_pause99_add_user_Definitely => 1, + pause99_add_user_userid => "NEWUSER", + pause99_add_user_fullname => "new user", + pause99_add_user_email => "new_user\@localhost.localdomain", + pause99_add_user_homepage => "http://home.page", +}; + +my $new_mailing_list = { + SUBMIT_pause99_add_user_Definitely => 1, + pause99_add_user_userid => "MAILLIST", + pause99_add_user_fullname => "Mailing List", + pause99_add_user_email => "ml\@localhost.localdomain", + pause99_add_user_subscribe => "how to subscribe", +}; + +my $default = { + HIDDENNAME => "TESTUSER", + ACTIONREQ => "edit_ml", + pause99_select_ml_action_sub => 1, +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=add_user"); + # note $t->content; + } +}; + +subtest 'post: ordinary user' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->reset_fixture; + $t->post_ok("$path?ACTION=add_user", $new_user); + # note $t->content; + + # new user exists + my $rows = $t->mod_db->select('users', ['*'], { + userid => $new_user->{pause99_add_user_userid}, + }); + is @$rows => 1; + for my $key (qw/userid homepage fullname/) { + is $rows->[0]{$key} => $new_user->{"pause99_add_user_$key"}, "$key is stored correctly"; + } + is $rows->[0]{email} => 'CENSORED'; # email in the user table is always CENSORED + + # email tests; censored email shouldn't be disclosed to admins + my @deliveries = $t->deliveries; + my @welcome_emails = grep { $_->header('Subject') =~ /Welcome/ } @deliveries; + is @welcome_emails => 2; + my ($welcome_for_user) = grep { $_->header('To') =~ /new_user/ } @welcome_emails; + like $welcome_for_user->body => qr/email:\s+new_user\@localhost/; + + my ($welcome_for_admins) = grep { $_->header('To') =~ /admin/ } @welcome_emails; + unlike $welcome_for_admins->body => qr/email:\s+new_user\@localhost/; + like $welcome_for_admins->body => qr/email:\s+CENSORED/; + } +}; + +subtest 'post: user with an accent in their name' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->reset_fixture; + $t->post_ok("$path?ACTION=add_user", { + %$new_user, + pause99_add_user_fullname => "T\xc3\xa9st Name", + }); + # note $t->content; + + # new user exists + my $rows = $t->mod_db->select('users', ['*'], { + userid => $new_user->{pause99_add_user_userid}, + }); + is @$rows => 1; + SKIP: { + skip "FIXME: seems not so stable; probably needs more explicit configuration", 1; + is $rows->[0]{fullname} => "T\xc3\xa9st Name"; + } + } +}; + +subtest 'post: soundex' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %copied_user = %$new_user; + $copied_user{pause99_add_user_fullname} = 'new user'; + $copied_user{SUBMIT_pause99_add_user_Soundex} = 1; + delete $copied_user{SUBMIT_pause99_add_user_Definitely}; + + $t->reset_fixture; + $t->post_ok("$path?ACTION=add_user", { + %copied_user, + }); + # note $t->content; + + # new user exists + my $rows = $t->mod_db->select('users', ['*'], { + userid => $new_user->{pause99_add_user_userid}, + }); + is @$rows => 1; + } +}; + +subtest 'post: soundex error: similar name' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %copied_user = %$new_user; + $copied_user{pause99_add_user_fullname} = 'new nome'; + $copied_user{SUBMIT_pause99_add_user_Soundex} = 1; + delete $copied_user{SUBMIT_pause99_add_user_Definitely}; + + $t->reset_fixture; + $t->post_ok("$path?ACTION=add_user", { + %copied_user, + }); + $t->text_like('h3', qr/Not submitting NEWUSER, maybe we have a duplicate/); + # note $t->content; + + # new user does not exist + my $rows = $t->mod_db->select('users', ['*'], { + userid => $new_user->{pause99_add_user_userid}, + }); + is @$rows => 0; + } +}; + +subtest 'post: metaphone' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %copied_user = %$new_user; + $copied_user{pause99_add_user_fullname} = 'new user'; + $copied_user{SUBMIT_pause99_add_user_Metaphone} = 1; + delete $copied_user{SUBMIT_pause99_add_user_Definitely}; + + $t->reset_fixture; + $t->post_ok("$path?ACTION=add_user", { + %copied_user, + }); + # note $t->content; + + # new user exists + my $rows = $t->mod_db->select('users', ['*'], { + userid => $new_user->{pause99_add_user_userid}, + }); + is @$rows => 1; + } +}; + +subtest 'post: metaphone error: similar name' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %copied_user = %$new_user; + $copied_user{pause99_add_user_fullname} = 'new nome'; + $copied_user{SUBMIT_pause99_add_user_Metaphone} = 1; + delete $copied_user{SUBMIT_pause99_add_user_Definitely}; + + $t->reset_fixture; + $t->post_ok("$path?ACTION=add_user", { + %copied_user, + }); + $t->text_like('h3', qr/Not submitting NEWUSER, maybe we have a duplicate/); + # note $t->content; + + # new user does not exist + my $rows = $t->mod_db->select('users', ['*'], { + userid => $new_user->{pause99_add_user_userid}, + }); + is @$rows => 0; + } +}; + +subtest 'post: metaphone error: completely duplicated' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %copied_user = %$new_user; + $copied_user{SUBMIT_pause99_add_user_Metaphone} = 1; + delete $copied_user{SUBMIT_pause99_add_user_Definitely}; + + $t->reset_fixture; + $t->post_ok("$path?ACTION=add_user", { + %copied_user, + }); + + # new user exists + my $rows = $t->mod_db->select('users', ['*'], { + userid => $new_user->{pause99_add_user_userid}, + }); + is @$rows => 1; + + $t->post_ok("$path?ACTION=add_user", { + %copied_user, + }); + $t->text_like('h3', qr/Not submitting NEWUSER, maybe we have a duplicate/); + # note $t->content; + } +}; + +subtest 'post: mailing list' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->reset_fixture; + $t->post_ok("$path?ACTION=add_user", $new_mailing_list); + # note $t->content; + + # new mailing list exists + my $rows = $t->mod_db->select('maillists', ['*'], { + maillistid => $new_mailing_list->{pause99_add_user_userid}, + }); + is @$rows => 1; + + # new user also exists + $rows = $t->mod_db->select('users', ['*'], { + userid => $new_mailing_list->{pause99_add_user_userid}, + }); + is @$rows => 1; + } +}; + +subtest 'get: retrieve a stored session' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %requested_user; + for my $key (keys %$new_user) { + next if $key =~ /SUBMIT/; + my $new_key = $key =~ s/add_user/request_id/r; + $requested_user{$new_key} = $new_user->{$key}; + } + $requested_user{pause99_request_id_rationale} = 'Rational to request PAUSE ID'; + $requested_user{SUBMIT_pause99_request_id_sub} = 1; + + $t->reset_fixture; + $t->post_ok("$path?ACTION=request_id", \%requested_user); + my ($email) = map {$_->body} $t->deliveries; + my ($userid) = $email =~ m!https://.+?/pause/authenquery.+?USERID=([^&\s]+)!; + like $userid => qr/\A\d+_\w+\z/; + $t->clear_deliveries; + + $t->get_ok("$path?ACTION=add_user&USERID=$userid"); + # note $t->content; + + for my $key (keys %$new_user) { + next if $key =~ /SUBMIT/; + is $t->dom->at("input[name=$key]")->attr('value') => $new_user->{$key}, "$key is set correctly"; + } + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/change_passwd.t b/t/pause_2025/action_2025/change_passwd.t new file mode 100644 index 000000000..c447fb14c --- /dev/null +++ b/t/pause_2025/action_2025/change_passwd.t @@ -0,0 +1,227 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use Time::Piece; +use utf8; + +my $default = { + pause99_change_passwd_pw1 => "new_pass", + pause99_change_passwd_pw2 => "new_pass", + pause99_change_passwd_sub => 1, +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=change_passwd"); + # note $t->content; + } +}; + +subtest 'get: public without ABRA' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + next if $user; # public only + my $t = Test::PAUSE::Web->new(user => $user); + $t->authen_dbh->do('TRUNCATE abrakadabra'); + my $res = $t->get("$path?ACTION=change_passwd"); + is $res->code => 403; + # note $t->content; + } +}; + +subtest 'get: public with ABRA' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + next if $user; # public only + my $t = Test::PAUSE::Web->new(user => $user); + + my $chuser = 'TESTUSER'; + my $chpass = 'testpassword'; + $t->authen_dbh->do('TRUNCATE abrakadabra'); + ok $t->authen_db->insert('abrakadabra', { + user => $chuser, + chpasswd => $chpass, + expires => Time::Piece->new(time + 3600)->strftime('%Y-%m-%d %H:%M:%S'), + }); + + $t->get_ok("$path?ACTION=change_passwd&ABRA=$chuser.$chpass"); + # note $t->content; + + # No links should keep ABRA (71a745d) + my @links = map {$_->attr('href')} $t->dom->at('a'); + ok !grep {$_ =~ /ABRA=/} @links; + } +}; + +subtest 'post: basic' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my %form = %$default; + my $t = Test::PAUSE::Web->new(user => $user); + my $res = $t->post("$path?ACTION=change_passwd", \%form); + ok !$res->is_success && $res->code == 403, "Forbidden"; + like $res->content => qr/Failed CSRF check/; + # note $t->content; + } +}; + +subtest 'post_with_token: basic' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my %form = %$default; + my $t = Test::PAUSE::Web->new(user => $user); + $t->post_with_token_ok("$path?ACTION=change_passwd", \%form) + ->text_like("p.password_stored", qr/New password stored/); + is $t->deliveries => 1, "one delivery for admin"; + # note $t->content; + } +}; + +subtest 'post_with_token: user with CENSORED email' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + $user = "TESTCNSRD" if $user eq "TESTUSER"; + + my %form = %$default; + my $t = Test::PAUSE::Web->new(user => $user); + $t->post_with_token_ok("$path?ACTION=change_passwd", \%form) + ->text_like("p.password_stored", qr/New password stored/); + my @deliveries = $t->deliveries; + is @deliveries => 1, "one delivery for admin"; + my $email = $deliveries[0]->as_string; + unlike $email => qr/CENSORED/; + like $email => qr/testcnsrd\@localhost/; + note $email; + # note $t->content; + } +}; + +subtest 'post_with_token: public without ABRA' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + next if $user; # public only + my $t = Test::PAUSE::Web->new(user => $user); + $t->authen_dbh->do('TRUNCATE abrakadabra'); + + my %form = %$default; + my $res = $t->post_with_token("$path?ACTION=change_passwd", \%form); + is $res->code => 403; + # note $t->content; + } +}; + +subtest 'post_with_token: public with ABRA' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + next if $user; # public only + my $t = Test::PAUSE::Web->new(user => $user); + + my $chuser = 'TESTUSER'; + my $chpass = 'testpassword'; + $t->authen_dbh->do('TRUNCATE abrakadabra'); + ok $t->authen_db->insert('abrakadabra', { + user => $chuser, + chpasswd => $chpass, + expires => Time::Piece->new(time + 3600)->strftime('%Y-%m-%d %H:%M:%S'), + }); + + my %form = %$default; + $t->post_with_token_ok("$path?ACTION=change_passwd&ABRA=$chuser.$chpass", \%form); + $t->text_like("p.password_stored", qr/New password stored/); + # note $t->content; + + # No links should keep ABRA (71a745d) + my @links = map {$_->attr('href')} $t->dom->at('a'); + ok !grep {$_ =~ /ABRA=/} @links; + + # Used ABRA is gone (8234a6a) + my $res = $t->post_with_token("$path?ACTION=change_passwd&ABRA=$chuser.$chpass", \%form); + ok !$res->is_success; + is $res->code => 401; + } +}; + +subtest 'post_with_token: public with incorrect ABRA' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + next if $user; # public only + my $t = Test::PAUSE::Web->new(user => $user); + + my $chuser = 'TESTUSER'; + my $chpass = 'testpassword'; + $t->authen_dbh->do('TRUNCATE abrakadabra'); + ok $t->authen_db->insert('abrakadabra', { + user => $chuser, + chpasswd => $chpass, + expires => Time::Piece->new(time + 3600)->strftime('%Y-%m-%d %H:%M:%S'), + }); + + my %form = %$default; + my $res = $t->post_with_token("$path?ACTION=change_passwd&ABRA=$chuser.wrong$chpass", \%form); + is $res->code => 401; + # note $t->content; + } +}; + +subtest 'post_with_token: passwords mismatch' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_change_passwd_pw2 => "wrong_pass", + ); + $t->post_with_token_ok("$path?ACTION=change_passwd", \%form) + ->text_is("h2", "Error") + ->text_like("p.error_message", qr/The two passwords didn't match./); + ok !$t->deliveries, "no delivery for admin"; + # note $t->content; + } +}; + +subtest 'post_with_token: only one password' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_change_passwd_pw2 => undef, + ); + $t->post_with_token_ok("$path?ACTION=change_passwd", \%form) + ->text_is("h2", "Error") + ->text_like("p.error_message", qr/You need to fill in the same password in both fields./); + ok !$t->deliveries, "no delivery for admin"; + # note $t->content; + } +}; + +subtest 'post_with_token: no password' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_change_passwd_pw1 => undef, + pause99_change_passwd_pw2 => undef, + ); + $t->post_with_token_ok("$path?ACTION=change_passwd", \%form) + ->text_is("h2", "Error") + ->text_like("p.error_message", qr/Please fill in the form with passwords./); + ok !$t->deliveries, "no delivery for admin"; + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/delete_files.t b/t/pause_2025/action_2025/delete_files.t new file mode 100644 index 000000000..07ea06525 --- /dev/null +++ b/t/pause_2025/action_2025/delete_files.t @@ -0,0 +1,244 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +my $default_for_add_uri = { + pause99_add_uri_httpupload => [Test::PAUSE::Web->file_to_upload], + SUBMIT_pause99_add_uri_httpupload => 1, +}; + +my $default = { + pause99_delete_files_FILE => ["Hash-RenameKey-0.02.tar.gz"], +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=delete_files"); + # note $t->content; + } +}; + +subtest 'post: basic' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->mod_dbh->do("TRUNCATE uris"); + $t->mod_dbh->do("TRUNCATE deletes"); + $t->remove_authors_dir($user); + + # prepare distribution + $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + + $t->copy_to_authors_dir($user, scalar Test::PAUSE::Web->file_to_upload); + + # delete + my %form = %$default; + $form{SUBMIT_pause99_delete_files_delete} = 1; + $t->post_ok("$path?ACTION=delete_files", \%form); + # note $t->content; + + my @deliveries = $t->deliveries; + is @deliveries => 2; + my ($mail_body) = map {$_->body} @deliveries; + like $mail_body => qr/ACTION=delete_files/; + + my $rows = $t->mod_db->select('deletes', ['*']); + is @$rows => 1; + like $rows->[0]{deleteid} => qr!/$form{pause99_delete_files_FILE}[0]$!; + + # undelete + delete $form{SUBMIT_pause99_delete_files_delete}; + $form{SUBMIT_pause99_delete_files_undelete} = 1; + $t->post_ok("$path?ACTION=delete_files", \%form); + # note $t->content; + + ok $rows = $t->mod_db->select('deletes', ['*']); + ok !@$rows; + } +}; + +subtest 'post: absolute path' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->mod_dbh->do("TRUNCATE uris"); + $t->mod_dbh->do("TRUNCATE deletes"); + $t->remove_authors_dir($user); + + # prepare distribution + $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + + my $copied = $t->copy_to_authors_dir($user, scalar Test::PAUSE::Web->file_to_upload); + ok(File::Spec->file_name_is_absolute($copied)); + + # delete + my %form = ( + pause99_delete_files_FILE => [$copied], + SUBMIT_pause99_delete_files_delete => 1 + ); + $t->post_ok("$path?ACTION=delete_files", \%form); + # note $t->content; + + my @deliveries = $t->deliveries; + is @deliveries => 2; + my ($mail_body) = map {$_->body} @deliveries; + like $mail_body => qr/WARNING: illegal filename/; + + my $rows = $t->mod_db->select('deletes', ['*']); + ok !@$rows; + } +}; + +subtest 'post: file not found' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->mod_dbh->do("TRUNCATE uris"); + $t->mod_dbh->do("TRUNCATE deletes"); + $t->remove_authors_dir($user); + + # prepare distribution + $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + + my $copied = $t->copy_to_authors_dir($user, scalar Test::PAUSE::Web->file_to_upload); + + # delete + my %form = ( + pause99_delete_files_FILE => ['Something-Else-0.02.tar.gz'], + SUBMIT_pause99_delete_files_delete => 1 + ); + $t->post_ok("$path?ACTION=delete_files", \%form); + # note $t->content; + + my @deliveries = $t->deliveries; + is @deliveries => 2; + my ($mail_body) = map {$_->body} @deliveries; + like $mail_body => qr/WARNING: file not found/; + + my $rows = $t->mod_db->select('deletes', ['*']); + ok !@$rows; + } +}; + +subtest 'post: CHECKSUMS' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->mod_dbh->do("TRUNCATE uris"); + $t->mod_dbh->do("TRUNCATE deletes"); + $t->remove_authors_dir($user); + + # prepare distribution + $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + + my $copied = $t->copy_to_authors_dir($user, scalar Test::PAUSE::Web->file_to_upload); + $t->save_to_authors_dir($user, "CHECKSUMS", "CHECKSUMS"); + + # delete + my %form = ( + pause99_delete_files_FILE => ['CHECKSUMS'], + SUBMIT_pause99_delete_files_delete => 1 + ); + $t->post_ok("$path?ACTION=delete_files", \%form); + # note $t->content; + + my @deliveries = $t->deliveries; + is @deliveries => 2; + my ($mail_body) = map {$_->body} @deliveries; + like $mail_body => qr/WARNING: CHECKSUMS not erasable/; + + my $rows = $t->mod_db->select('deletes', ['*']); + ok !@$rows; + } +}; + +subtest 'post: readme' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->mod_dbh->do("TRUNCATE uris"); + $t->mod_dbh->do("TRUNCATE deletes"); + $t->remove_authors_dir($user); + + # prepare distribution + $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + + my $copied = $t->copy_to_authors_dir($user, scalar Test::PAUSE::Web->file_to_upload); + $t->save_to_authors_dir($user, "Hash-RenameKey-0.02.readme", "README"); + + # delete + my %form = %$default; + $form{SUBMIT_pause99_delete_files_delete} = 1; + $t->post_ok("$path?ACTION=delete_files", \%form); + # note $t->content; + + # .readme is deleted when a related tarball is removed + my @deliveries = $t->deliveries; + is @deliveries => 2; + my ($mail_body) = map {$_->body} @deliveries; + like $mail_body => qr/\.readme/; + + my $rows = $t->mod_db->select('deletes', ['*']); + is @$rows => 2; + ok grep {$_->{deleteid} =~ /\.readme$/} @$rows; + } +}; + +subtest 'post: delete by admin using select_user' => sub { + { + my $test = Test::PAUSE::Web->tests_for('user'); + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->mod_dbh->do("TRUNCATE uris"); + $t->mod_dbh->do("TRUNCATE deletes"); + $t->remove_authors_dir($user); + + # prepare distribution + $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + + my $copied = $t->copy_to_authors_dir($user, scalar Test::PAUSE::Web->file_to_upload); + } + { + my $test = Test::PAUSE::Web->tests_for('admin'); + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %action_form = ( + HIDDENNAME => "TESTUSER", + ACTIONREQ => "delete_files", + pause99_select_user_sub => 1, + ); + $t->post_ok("$path?ACTION=select_user", \%action_form); + # note $t->content; + + # delete + my %form = %$default; + $form{SUBMIT_pause99_delete_files_delete} = 1; + $form{HIDDENNAME} = "TESTUSER"; + $t->post_ok("$path?ACTION=delete_files", \%form); + # note $t->content; + + my @deliveries = $t->deliveries; + is @deliveries => 3; # for TESTUSER, TESTADMIN, pause_admin + my ($mail_body) = map {$_->body} @deliveries; + like $mail_body => qr/ACTION=delete_files/; + + my $rows = $t->mod_db->select('deletes', ['*']); + is @$rows => 1; + like $rows->[0]{deleteid} => qr!/$form{pause99_delete_files_FILE}[0]$!; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/edit_cred.t b/t/pause_2025/action_2025/edit_cred.t new file mode 100644 index 000000000..507859f8f --- /dev/null +++ b/t/pause_2025/action_2025/edit_cred.t @@ -0,0 +1,65 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +my $default = { + pause99_edit_cred_fullname => "new fullname", + pause99_edit_cred_asciiname => "new ascii name", + pause99_edit_cred_email => "new_email\@localhost.localdomain", + pause99_edit_cred_homepage => "none", + pause99_edit_cred_cpan_mail_alias => "none", + pause99_edit_cred_sub => 1, +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=edit_cred"); + # note $t->content; + } +}; + +subtest 'post: basic' => sub { + plan skip_all => 'SKIP for now'; + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = %$default; + $t->post_ok("$path?ACTION=edit_cred", \%form); + # note $t->content; + } +}; + +subtest 'post_with_token: basic' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = %$default; + $t->post_with_token_ok("$path?ACTION=edit_cred", \%form); + # note $t->content; + } +}; + +subtest 'post_with_token: edit with CENSORED email' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + Test::PAUSE::Web->setup; + $t->mod_db->update('users', { email => 'CENSORED' }, { userid => $user }); + my %form = (%$default, pause99_edit_cred_email => 'CENSORED'); + $t->post_with_token_ok("$path?ACTION=edit_cred", \%form); + my @deliveries = $t->deliveries; + like $deliveries[0]->as_string => qr/\[CENSORED\]/; + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/edit_ml.t b/t/pause_2025/action_2025/edit_ml.t new file mode 100644 index 000000000..535653cd9 --- /dev/null +++ b/t/pause_2025/action_2025/edit_ml.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=edit_ml"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/edit_uris.t b/t/pause_2025/action_2025/edit_uris.t new file mode 100644 index 000000000..80c882fdc --- /dev/null +++ b/t/pause_2025/action_2025/edit_uris.t @@ -0,0 +1,45 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +my $default_for_add_uri = { + pause99_add_uri_httpupload => ["$Test::PAUSE::Web::AppRoot/t/staging/Hash-RenameKey-0.02.tar.gz", "Hash-RenameKey-0.02.tar.gz"], + SUBMIT_pause99_add_uri_httpupload => 1, +}; + +my $default = { + pause99_edit_uris_3 => "T/TE/TESTUSER/Hash-RenameKey-0.02.tar.gz", + pause99_edit_uris_2 => 1, +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=edit_uris"); + # note $t->content; + } +}; + +subtest 'post: basic' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->mod_dbh->do("TRUNCATE uris"); + + # prepare distribution + $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + + my %form = %$default; + $form{pause99_edit_uris_3} =~ s/TESTUSER/$user/; + $t->post_ok("$path?ACTION=edit_uris", \%form); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/email_for_admin.t b/t/pause_2025/action_2025/email_for_admin.t new file mode 100644 index 000000000..4d86b2991 --- /dev/null +++ b/t/pause_2025/action_2025/email_for_admin.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=email_for_admin"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/giveup_comaint.t b/t/pause_2025/action_2025/giveup_comaint.t new file mode 100644 index 000000000..c1cb6e4f0 --- /dev/null +++ b/t/pause_2025/action_2025/giveup_comaint.t @@ -0,0 +1,112 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_share_perms_remome_m => "Module::Comaint", + SUBMIT_pause99_share_perms_remome => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=giveup_comaint"); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Comaint + Module::Comaint::Foo + Module::User::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::Comaint + Module::Comaint::Foo + /]) or note explain \@modules; + } + # note $t->content; + } +}; + +subtest 'normal case (comaint)' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_share_perms_remome_m => [qw/Module::Comaint Module::Comaint::Foo/], + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=giveup_comaint", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::User::Foo + /]) or note explain \@modules; + eq_or_diff(\@results, [ + 'Removed TESTADMIN from co-maintainers of Module::Comaint.', + 'Removed TESTADMIN from co-maintainers of Module::Comaint::Foo.', + ]); + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + /]) or note explain \@modules; + eq_or_diff(\@results, [ + 'Removed TESTUSER from co-maintainers of Module::Comaint.', + 'Removed TESTUSER from co-maintainers of Module::Comaint::Foo.', + ]); + } + # note $t->content; + } +}; + +subtest 'unrelated modules' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_share_perms_remome_m => [qw/Module::Unrelated Module::Unrelated::Foo/], + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=giveup_comaint", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Comaint + Module::Comaint::Foo + Module::User::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::Comaint + Module::Comaint::Foo + /]) or note explain \@modules; + } + ok !@results; + eq_or_diff(\@errors, [ + 'You do not seem to be co-maintainer of Module::Unrelated' + ]) or note explain \@errors; + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/giveup_dist_comaint.t b/t/pause_2025/action_2025/giveup_dist_comaint.t new file mode 100644 index 000000000..7e4e97a91 --- /dev/null +++ b/t/pause_2025/action_2025/giveup_dist_comaint.t @@ -0,0 +1,109 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_giveup_dist_comaint_d => "Module-Comaint", + SUBMIT_pause99_giveup_dist_comaint => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + Test::PAUSE::Web->reset_module_fixture; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=giveup_dist_comaint"); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + Module-Comaint + Module-User + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + Module-Comaint + /]) or note explain \@dists; + } + # note $t->content; + } +}; + +subtest 'normal case (comaint)' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_giveup_dist_comaint_d => [qw/Module-Comaint/], + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=giveup_dist_comaint", \%form); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + Module-User + /]) or note explain \@dists; + eq_or_diff(\@results, [ + 'Removed TESTADMIN from co-maintainers of Module::Comaint (Module-Comaint).', + 'Removed TESTADMIN from co-maintainers of Module::Comaint::Foo (Module-Comaint).', + ]); + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + /]) or note explain \@dists; + eq_or_diff(\@results, [ + 'Removed TESTUSER from co-maintainers of Module::Comaint (Module-Comaint).', + 'Removed TESTUSER from co-maintainers of Module::Comaint::Foo (Module-Comaint).', + ]); + } + # note $t->content; + } +}; + +subtest 'unrelated dists' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_giveup_dist_comaint_d => [qw/Module-Unrelated/], + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=giveup_dist_comaint", \%form); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + Module-Comaint + Module-User + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + Module-Comaint + /]) or note explain \@dists; + } + ok !@results; + eq_or_diff(\@errors, [ + 'You do not seem to be co-maintainer of Module-Unrelated' + ]) or note explain \@errors; + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/mailpw.t b/t/pause_2025/action_2025/mailpw.t new file mode 100644 index 000000000..5aadcfe7e --- /dev/null +++ b/t/pause_2025/action_2025/mailpw.t @@ -0,0 +1,175 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +my $default = { + pause99_mailpw_1 => "TESTUSER", + pause99_mailpw_sub => 1, +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=mailpw"); + #note $t->content; + } +}; + +subtest 'post: basic' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$default; + $t->authen_dbh->do("TRUNCATE abrakadabra"); + my $res = $t->post("$path?ACTION=mailpw", \%form); + ok !$res->is_success && $res->code == 403, "Forbidden"; + like $res->content => qr/Failed CSRF check/; + # note $t->content; + } +}; + +subtest 'post_with_token: basic' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$default; + $t->authen_dbh->do("TRUNCATE abrakadabra"); + $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + ->text_like("p.form_response", qr/A token to change the password/); + # note $t->content; + } +}; + +subtest 'got an email instead of a userid' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_mailpw_1 => 'INV@LID', + ); + $t->authen_dbh->do("TRUNCATE abrakadabra"); + $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + ->text_is('h2', 'Error') + ->text_like('p.error_message', qr/Please supply a userid/s); + } +}; + +subtest 'invalid userid' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_mailpw_1 => 'INV#LID', + ); + $t->authen_dbh->do("TRUNCATE abrakadabra"); + $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + ->text_is('h2', 'Error') + ->text_like('p.error_message', qr/A userid of INV#LID is not allowed/s); + } +}; + +subtest 'cannot find a userid' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_mailpw_1 => 'NOTFOUND', + ); + $t->authen_dbh->do("TRUNCATE abrakadabra"); + $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + ->text_is('h2', 'Error') + ->text_like('p.error_message', qr/Cannot find a userid.+NOTFOUND/s); + # note $t->content; + } +}; + +subtest 'no secretmail' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + ); + $t->authen_dbh->do("TRUNCATE abrakadabra"); + $t->authen_db->update('usertable', {secretemail => undef}, {user => "TESTUSER"}); + $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + ->text_like("p.form_response", qr/A token to change the password/); + # note $t->content; + } + + Test::PAUSE::Web->setup; # restore the original state +}; + +subtest 'requested recently' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$default; + $t->authen_dbh->do("TRUNCATE abrakadabra"); + $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + ->text_like("p.form_response", qr/A token to change the password/); + $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + ->text_is('h2', 'Error') + ->text_like('p.error_message', qr/A token for TESTUSER that allows/s); + # note $t->content; + } +}; + +subtest 'user without an entry in usertable: has email' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_mailpw_1 => "OTHERUSER", + ); + $t->authen_dbh->do("TRUNCATE abrakadabra"); + $t->mod_db->insert('users', { + userid => 'OTHERUSER', + email => 'foo@localhost', + }, {replace => 1}); + $t->authen_db->delete('usertable', {user => 'OTHERUSER'}); + ok !@{ $t->authen_db->select('usertable', ['user'], {user => 'OTHERUSER'}) // [] }; + $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + ->text_like("p.form_response", qr/A token to change the password/); + + # new usertable entry is created + ok @{ $t->authen_db->select('usertable', ['user'], {user => 'OTHERUSER'}) // [] }; + #note $t->content; + } +}; + +subtest 'user without an entry in usertable: without email' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_mailpw_1 => "OTHERUSER", + ); + $t->authen_dbh->do("TRUNCATE abrakadabra"); + $t->mod_db->insert('users', { + userid => 'OTHERUSER', + email => '', + }, {replace => 1}); + $t->authen_db->delete('usertable', {user => 'OTHERUSER'}); + ok !@{ $t->authen_db->select('usertable', ['user'], {user => 'OTHERUSER'}) // [] }; + $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + ->text_is('h2', 'Error') + ->text_like('p.error_message', qr/A userid of OTHERUSER\s+is not known/s); + + # new usertable entry is not created + ok !@{ $t->authen_db->select('usertable', ['user'], {user => 'OTHERUSER'}) // [] }; + #note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/make_comaint.t b/t/pause_2025/action_2025/make_comaint.t new file mode 100644 index 000000000..0263244b6 --- /dev/null +++ b/t/pause_2025/action_2025/make_comaint.t @@ -0,0 +1,170 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_share_perms_makeco_m => [], + pause99_share_perms_makeco_a => "TESTUSER2", + SUBMIT_pause99_share_perms_makeco => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=make_comaint"); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_set(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + } + # note $t->content; + } +}; + +subtest 'normal case' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @packages; + if ($user eq 'TESTADMIN') { + @packages = qw/Module::Admin::Bar/; + } + if ($user eq 'TESTUSER') { + @packages = qw/Module::User::Bar/; + } + + my %form = ( + %$default, + pause99_share_perms_makeco_m => \@packages, + pause99_share_perms_makeco_a => "TESTUSER4", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=make_comaint", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + eq_or_diff(\@results, [ + 'Added TESTUSER4 to co-maintainers of Module::Admin::Bar.', + ]); + } + if ($user eq 'TESTUSER') { + cmp_set(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + eq_or_diff(\@results, [ + 'Added TESTUSER4 to co-maintainers of Module::User::Bar.', + ]); + } + note $t->content; + } +}; +done_testing;exit; + +subtest 'unknown user' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @packages; + if ($user eq 'TESTADMIN') { + @packages = qw/Module::Admin::Bar/; + } + if ($user eq 'TESTUSER') { + @packages = qw/Module::User::Bar/; + } + + my %form = ( + %$default, + pause99_share_perms_makeco_m => \@packages, + pause99_share_perms_makeco_a => "UNKNOWN", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=make_comaint", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + } + ok !@results; + eq_or_diff(\@errors, [ + 'UNKNOWN is not a valid userid.', + ]); + # note $t->content; + } +}; + +subtest 'unrelated modules' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_share_perms_makeco_m => [qw/Module::Unrelated/], + pause99_share_perms_makeco_a => "TESTUSER2", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=make_comaint", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + } + ok !@results; + eq_or_diff(\@errors, [ + 'You do not seem to be maintainer of Module::Unrelated', + ]); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/make_dist_comaint.t b/t/pause_2025/action_2025/make_dist_comaint.t new file mode 100644 index 000000000..2bd1cc9d3 --- /dev/null +++ b/t/pause_2025/action_2025/make_dist_comaint.t @@ -0,0 +1,165 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_make_dist_comaint_d => [], + pause99_make_dist_comaint_a => "TESTUSER2", + SUBMIT_pause99_make_dist_comaint => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=make_dist_comaint"); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@dists, [qw/ + Module-Admin + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_set(\@dists, [qw/ + Module-User + Module-User-Foo-Baz + /]) or note explain \@dists; + } + + # note $t->content; + } +}; + +subtest 'normal case' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @dists; + if ($user eq 'TESTADMIN') { + @dists = qw/Module-Admin/; + } + if ($user eq 'TESTUSER') { + @dists = qw/Module-User/; + } + + my %form = ( + %$default, + pause99_make_dist_comaint_d => \@dists, + pause99_make_dist_comaint_a => "TESTUSER4", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=make_dist_comaint", \%form); + @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@dists, [qw/ + Module-Admin + /]) or note explain \@dists; + eq_or_diff(\@results, [ + 'Added TESTUSER4 to co-maintainers of Module::Admin::Bar (Module-Admin).', + 'Added TESTUSER4 to co-maintainers of Module::Admin::Foo (Module-Admin).', + ]); + } + if ($user eq 'TESTUSER') { + cmp_set(\@dists, [qw/ + Module-User + Module-User-Foo-Baz + /]) or note explain \@dists; + eq_or_diff(\@results, [ + 'Added TESTUSER4 to co-maintainers of Module::User::Bar (Module-User).', + 'Added TESTUSER4 to co-maintainers of Module::User::Foo (Module-User).', + ]); + } + + # note $t->content; + } +}; + +subtest 'unknown user' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @dists; + if ($user eq 'TESTADMIN') { + @dists = qw/Module-Admin/; + } + if ($user eq 'TESTUSER') { + @dists = qw/Module-User/; + } + + my %form = ( + %$default, + pause99_make_dist_comaint_d => \@dists, + pause99_make_dist_comaint_a => "UNKNOWN", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=make_dist_comaint", \%form); + @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + Module-Admin + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + Module-User + Module-User-Foo-Baz + /]) or note explain \@dists; + } + ok !@results; + eq_or_diff(\@errors, [ + 'UNKNOWN is not a valid userid.', + ]); + # note $t->content; + } +}; + +subtest 'unrelated dists' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_make_dist_comaint_d => [qw/Module-Unrelated/], + pause99_make_dist_comaint_a => "TESTUSER2", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=make_dist_comaint", \%form); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + Module-Admin + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + Module-User + Module-User-Foo-Baz + /]) or note explain \@dists; + } + ok !@results; + eq_or_diff(\@errors, [ + 'You do not seem to be maintainer of Module-Unrelated', + ]); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/manage_id_requests.t b/t/pause_2025/action_2025/manage_id_requests.t new file mode 100644 index 000000000..9113a3a83 --- /dev/null +++ b/t/pause_2025/action_2025/manage_id_requests.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=manage_id_requests"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/move_dist_primary.t b/t/pause_2025/action_2025/move_dist_primary.t new file mode 100644 index 000000000..bcbd2132f --- /dev/null +++ b/t/pause_2025/action_2025/move_dist_primary.t @@ -0,0 +1,161 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_move_dist_primary_d => [], + pause99_move_dist_primary_a => "TESTUSER2", + SUBMIT_pause99_move_dist_primary => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=move_dist_primary"); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + Module-Admin + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + Module-User + Module-User-Foo-Baz + /]) or note explain \@dists; + } + # note $t->content; + } +}; + +subtest 'normal case' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @dists; + if ($user eq 'TESTADMIN') { + @dists = qw/Module-Admin/; + } + if ($user eq 'TESTUSER') { + @dists = qw/Module-User/; + } + + my %form = ( + %$default, + pause99_move_dist_primary_d => \@dists, + pause99_move_dist_primary_a => "TESTUSER2", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=move_dist_primary", \%form); + @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + /]) or note explain \@dists; + eq_or_diff(\@results, [ + 'Made TESTUSER2 primary maintainer of Module::Admin::Bar (Module-Admin).', + 'Made TESTUSER2 primary maintainer of Module::Admin::Foo (Module-Admin).', + ]); + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + Module-User-Foo-Baz + /]) or note explain \@dists; + eq_or_diff(\@results, [ + 'Made TESTUSER2 primary maintainer of Module::User::Bar (Module-User).', + 'Made TESTUSER2 primary maintainer of Module::User::Foo (Module-User).', + ]); + } + note $t->content; + } +}; + +subtest 'unknown user' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @dists; + if ($user eq 'TESTADMIN') { + @dists = qw/Module-Admin/; + } + if ($user eq 'TESTUSER') { + @dists = qw/Module-User/; + } + + my %form = ( + %$default, + pause99_move_dist_primary_d => \@dists, + pause99_move_dist_primary_a => "UNKNOWN", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=move_dist_primary", \%form); + my @new_dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@new_dists, [qw/ + Module-Admin + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@new_dists, [qw/ + Module-User + Module-User-Foo-Baz + /]) or note explain \@dists; + } + ok !@results; + eq_or_diff(\@errors, [ + 'UNKNOWN is not a valid userid.', + ]); + # note $t->content; + } +}; + +subtest 'unrelated dists' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_move_dist_primary_d => [qw/Module-Unrelated/], + pause99_move_dist_primary_a => "TESTUSER2", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=move_dist_primary", \%form); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + Module-Admin + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + Module-User + Module-User-Foo-Baz + /]) or note explain \@dists; + } + ok !@results; + eq_or_diff(\@errors, [ + 'You do not seem to be maintainer of Module-Unrelated', + ]); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/move_primary.t b/t/pause_2025/action_2025/move_primary.t new file mode 100644 index 000000000..e9a739229 --- /dev/null +++ b/t/pause_2025/action_2025/move_primary.t @@ -0,0 +1,168 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_share_perms_pr_m => [], + pause99_share_perms_movepr_a => "TESTUSER2", + SUBMIT_pause99_share_perms_movepr => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=move_primary"); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + } + # note $t->content; + } +}; + +subtest 'normal case' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @packages; + if ($user eq 'TESTADMIN') { + @packages = qw/Module::Admin::Bar/; + } + if ($user eq 'TESTUSER') { + @packages = qw/Module::User::Bar/; + } + + my %form = ( + %$default, + pause99_share_perms_pr_m => \@packages, + pause99_share_perms_movepr_a => "TESTUSER2", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=move_primary", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Admin::Foo + /]) or note explain \@modules; + eq_or_diff(\@results, [ + 'Made TESTUSER2 primary maintainer of Module::Admin::Bar.', + ]); + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + eq_or_diff(\@results, [ + 'Made TESTUSER2 primary maintainer of Module::User::Bar.', + ]); + } + # note $t->content; + } +}; + +subtest 'unknown user' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @packages; + if ($user eq 'TESTADMIN') { + @packages = qw/Module::Admin::Bar/; + } + if ($user eq 'TESTUSER') { + @packages = qw/Module::User::Bar/; + } + + my %form = ( + %$default, + pause99_share_perms_pr_m => \@packages, + pause99_share_perms_movepr_a => "UNKNOWN", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=move_primary", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + } + ok !@results; + eq_or_diff(\@errors, [ + 'UNKNOWN is not a valid userid.', + ]); + # note $t->content; + } +}; + +subtest 'unrelated modules' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_share_perms_pr_m => [qw/Module::Unrelated/], + pause99_share_perms_movepr_a => "TESTUSER2", + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=move_primary", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + } + ok !@results; + eq_or_diff(\@errors, [ + 'You do not seem to be maintainer of Module::Unrelated', + ]); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/pause_04about.t b/t/pause_2025/action_2025/pause_04about.t new file mode 100644 index 000000000..05773616f --- /dev/null +++ b/t/pause_2025/action_2025/pause_04about.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=pause_04about"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/pause_04imprint.t b/t/pause_2025/action_2025/pause_04imprint.t new file mode 100644 index 000000000..780605e78 --- /dev/null +++ b/t/pause_2025/action_2025/pause_04imprint.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=pause_04imprint"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/pause_05news.t b/t/pause_2025/action_2025/pause_05news.t new file mode 100644 index 000000000..e033387c2 --- /dev/null +++ b/t/pause_2025/action_2025/pause_05news.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=pause_05news"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/pause_06history.t b/t/pause_2025/action_2025/pause_06history.t new file mode 100644 index 000000000..79aed17ab --- /dev/null +++ b/t/pause_2025/action_2025/pause_06history.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=pause_06history"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/pause_logout.t b/t/pause_2025/action_2025/pause_logout.t new file mode 100644 index 000000000..2459230d3 --- /dev/null +++ b/t/pause_2025/action_2025/pause_logout.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=pause_logout"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/pause_namingmodules.t b/t/pause_2025/action_2025/pause_namingmodules.t new file mode 100644 index 000000000..443064d5d --- /dev/null +++ b/t/pause_2025/action_2025/pause_namingmodules.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=pause_namingmodules"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/pause_operating_model.t b/t/pause_2025/action_2025/pause_operating_model.t new file mode 100644 index 000000000..c502086ba --- /dev/null +++ b/t/pause_2025/action_2025/pause_operating_model.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=pause_operating_model"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/pause_privacy_policy.t b/t/pause_2025/action_2025/pause_privacy_policy.t new file mode 100644 index 000000000..d33518728 --- /dev/null +++ b/t/pause_2025/action_2025/pause_privacy_policy.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=pause_privacy_policy"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/peek_dist_perms.t b/t/pause_2025/action_2025/peek_dist_perms.t new file mode 100644 index 000000000..52532ea24 --- /dev/null +++ b/t/pause_2025/action_2025/peek_dist_perms.t @@ -0,0 +1,172 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use YAML::Syck; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_peek_dist_perms_query => "TESTUSER", + pause99_peek_dist_perms_by => "a", + pause99_peek_dist_perms_sub => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=peek_dist_perms"); + # note $t->content; + } +}; + +subtest 'search by author' => sub { + for my $method (qw/get_ok post_ok/) { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_peek_dist_perms_query => $user, + ); + $t->$method("$path?ACTION=peek_dist_perms", \%form); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + Module-Admin + Module-Comaint + Module-User + /]) or note explain \@dists; + ok grep(/^Module-Comaint/, @dists), 'Module-Comaint is also listed'; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + Module-Comaint + Module-User + Module-User-Foo-Baz + /]) or note explain \@dists; + } + # note $t->content; + + $t->$method("$path?ACTION=peek_dist_perms&OF=YAML", \%form); + my $list = YAML::Syck::Load( $t->content ); + if ($user eq 'TESTADMIN') { + eq_or_diff( $list => [ + { + 'dist' => 'Module-Admin', + 'owner' => 'TESTADMIN', + 'comaint' => 'TESTUSER2', + }, + { + 'dist' => 'Module-Comaint', + 'owner' => 'TESTUSER2', + 'comaint' => 'TESTADMIN', + }, + { + 'dist' => 'Module-User', + 'owner' => 'TESTUSER', + 'comaint' => 'TESTADMIN', + }, + ] ); + } + if ($user eq 'TESTUSER') { + eq_or_diff( $list => [ + { + 'dist' => 'Module-Comaint', + 'owner' => 'TESTUSER2', + 'comaint' => 'TESTUSER', + }, + { + 'dist' => 'Module-User', + 'owner' => 'TESTUSER', + 'comaint' => 'TESTADMIN,TESTUSER2', + }, + { + 'dist' => 'Module-User-Foo-Baz', + 'owner' => 'TESTUSER', + 'comaint' => undef, + }, + ] ); + } + } + } +}; + +subtest 'search by dist (exact)' => sub { + for my $method (qw/get_ok post_ok/) { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_peek_dist_perms_query => 'Module-User', + pause99_peek_dist_perms_by => 'de', + ); + $t->$method("$path?ACTION=peek_dist_perms", \%form); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + cmp_set(\@dists, [qw/ + Module-User + /]) or note explain \@dists; + # note $t->content; + + $t->$method("$path?ACTION=peek_dist_perms&OF=YAML", \%form); + my $list = YAML::Syck::Load( $t->content ); + eq_or_diff( $list => [ + { + 'dist' => 'Module-User', + 'owner' => 'TESTUSER', + 'comaint' => 'TESTADMIN,TESTUSER2', + }, + ]); + } + } +}; + +subtest 'search by module (sql-like)' => sub { + for my $method (qw/get_ok post_ok/) { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_peek_dist_perms_query => 'Module-User%', + pause99_peek_dist_perms_by => 'dl', + ); + $t->$method("$path?ACTION=peek_dist_perms", \%form); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + cmp_set(\@dists, [qw/ + Module-User + Module-User-Foo-Baz + /]) or note explain \@dists; + # note $t->content; + + $t->$method("$path?ACTION=peek_dist_perms&OF=YAML", \%form); + my $list = YAML::Syck::Load( $t->content ); + eq_or_diff( $list => [ + { + 'dist' => 'Module-User', + 'owner' => 'TESTUSER', + 'comaint' => 'TESTADMIN,TESTUSER2', + }, + { + 'dist' => 'Module-User-Foo-Baz', + 'owner' => 'TESTUSER', + 'comaint' => undef, + }, + ]); + } + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/peek_perms.t b/t/pause_2025/action_2025/peek_perms.t new file mode 100644 index 000000000..74f816693 --- /dev/null +++ b/t/pause_2025/action_2025/peek_perms.t @@ -0,0 +1,240 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use YAML::Syck; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_peek_perms_query => "TESTUSER", + pause99_peek_perms_by => "a", + pause99_peek_perms_sub => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=peek_perms"); + # note $t->content; + } +}; + +subtest 'search by author' => sub { + for my $method (qw/get_ok post_ok/) { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_peek_perms_query => $user, + ); + $t->$method("$path?ACTION=peek_perms", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.module')->each; + my @types = map {$_->all_text} $t->dom->find('td.type')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + Module::Comaint + Module::Comaint::Foo + Module::User::Foo + /]) or note explain \@modules; + ok grep(/co-maint/, @types), 'Has co-maint'; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::Comaint + Module::Comaint::Foo + Module::User::Bar + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + ok grep(/co-maint/, @types), 'No co-maint'; + } + # note $t->content; + + $t->$method("$path?ACTION=peek_perms&OF=YAML", \%form); + my $list = YAML::Syck::Load( $t->content ); + if ($user eq 'TESTADMIN') { + eq_or_diff( $list => [ + { + 'module' => 'Module::Admin::Bar', + 'owner' => 'TESTADMIN', + 'type' => 'first-come', + 'userid' => 'TESTADMIN' + }, + { + 'module' => 'Module::Admin::Foo', + 'owner' => 'TESTADMIN', + 'type' => 'first-come', + 'userid' => 'TESTADMIN' + }, + { + 'module' => 'Module::User::Foo', + 'owner' => 'TESTUSER', + 'type' => 'co-maint', + 'userid' => 'TESTADMIN' + }, + { + 'module' => 'Module::Comaint', + 'owner' => 'TESTUSER2', + 'type' => 'co-maint', + 'userid' => 'TESTADMIN' + }, + { + 'module' => 'Module::Comaint::Foo', + 'owner' => 'TESTUSER2', + 'type' => 'co-maint', + 'userid' => 'TESTADMIN' + }, + ] ); + } + if ($user eq 'TESTUSER') { + eq_or_diff( $list => [ + { + 'module' => 'Module::User::Bar', + 'owner' => 'TESTUSER', + 'type' => 'first-come', + 'userid' => 'TESTUSER' + }, + { + 'module' => 'Module::User::Foo', + 'owner' => 'TESTUSER', + 'type' => 'first-come', + 'userid' => 'TESTUSER' + }, + { + 'module' => 'Module::User::Foo::Baz', + 'owner' => 'TESTUSER', + 'type' => 'first-come', + 'userid' => 'TESTUSER' + }, + { + 'module' => 'Module::Comaint', + 'owner' => 'TESTUSER2', + 'type' => 'co-maint', + 'userid' => 'TESTUSER' + }, + { + 'module' => 'Module::Comaint::Foo', + 'owner' => 'TESTUSER2', + 'type' => 'co-maint', + 'userid' => 'TESTUSER' + }, + ] ); + } + } + } +}; + +subtest 'search by module (exact)' => sub { + for my $method (qw/get_ok post_ok/) { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_peek_perms_query => 'Module::User::Foo', + pause99_peek_perms_by => 'me', + ); + $t->$method("$path?ACTION=peek_perms", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.module')->each; + my @types = map {$_->all_text} $t->dom->find('td.type')->each; + cmp_set(\@modules, [qw/ + Module::User::Foo + /]) or note explain \@modules; + ok grep(/co-maint/, @types), 'Has co-maint'; + # note $t->content; + + $t->$method("$path?ACTION=peek_perms&OF=YAML", \%form); + my $list = YAML::Syck::Load( $t->content ); + eq_or_diff( $list => [ + { + 'module' => 'Module::User::Foo', + 'owner' => 'TESTUSER', + 'type' => 'first-come', + 'userid' => 'TESTUSER' + }, + { + 'module' => 'Module::User::Foo', + 'owner' => 'TESTUSER', + 'type' => 'co-maint', + 'userid' => 'TESTADMIN' + }, + ]); + } + } +}; + +subtest 'search by module (sql-like)' => sub { + for my $method (qw/get_ok post_ok/) { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_peek_perms_query => 'Module::User::%', + pause99_peek_perms_by => 'ml', + ); + $t->$method("$path?ACTION=peek_perms", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.module')->each; + my @types = map {$_->all_text} $t->dom->find('td.type')->each; + cmp_set(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + ok grep(/co-maint/, @types), 'Has co-maint'; + # note $t->content; + + $t->$method("$path?ACTION=peek_perms&OF=YAML", \%form); + my $list = YAML::Syck::Load( $t->content ); + eq_or_diff( $list => [ + { + 'module' => 'Module::User::Bar', + 'owner' => 'TESTUSER', + 'type' => 'first-come', + 'userid' => 'TESTUSER' + }, + { + 'module' => 'Module::User::Foo', + 'owner' => 'TESTUSER', + 'type' => 'first-come', + 'userid' => 'TESTUSER' + }, + { + 'module' => 'Module::User::Foo::Baz', + 'owner' => 'TESTUSER', + 'type' => 'first-come', + 'userid' => 'TESTUSER' + }, + { + 'module' => 'Module::User::Bar', + 'owner' => 'TESTUSER', + 'type' => 'co-maint', + 'userid' => 'TESTUSER2' + }, + { + 'module' => 'Module::User::Foo', + 'owner' => 'TESTUSER', + 'type' => 'co-maint', + 'userid' => 'TESTADMIN' + }, + ]); + } + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/reindex.t b/t/pause_2025/action_2025/reindex.t new file mode 100644 index 000000000..3d0df8430 --- /dev/null +++ b/t/pause_2025/action_2025/reindex.t @@ -0,0 +1,47 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +my $default_for_add_uri = { + pause99_add_uri_httpupload => [Test::PAUSE::Web->file_to_upload], + SUBMIT_pause99_add_uri_httpupload => 1, +}; + +my $default = { + pause99_reindex_FILE => ["Hash-RemoteKey-0.02.tar.gz"], + SUBMIT_pause99_reindex_delete => 1, +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=reindex"); + # note $t->content; + } +}; + +subtest 'post: basic' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + my $t = Test::PAUSE::Web->new(user => $user); + + $t->mod_dbh->do("TRUNCATE uris"); + + # prepare distribution + $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + + $t->copy_to_authors_dir($user, scalar Test::PAUSE::Web->file_to_upload); + + my %form = %$default; + $t->post_ok("$path?ACTION=reindex", \%form); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/remove_comaint.t b/t/pause_2025/action_2025/remove_comaint.t new file mode 100644 index 000000000..752dcba37 --- /dev/null +++ b/t/pause_2025/action_2025/remove_comaint.t @@ -0,0 +1,172 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_share_perms_remocos_tuples => [], + SUBMIT_pause99_share_perms_remocos => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=remove_comaint"); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_set(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + /]) or note explain \@modules; + } + # note $t->content; + } +}; + +subtest 'normal case' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @tuples; + if ($user eq 'TESTADMIN') { + @tuples = ( + 'Module::Admin::Bar -- TESTUSER2', + ); + } + if ($user eq 'TESTUSER') { + @tuples = ( + 'Module::User::Bar -- TESTUSER2', + ); + + } + + my %form = ( + %$default, + pause99_share_perms_remocos_tuples => \@tuples, + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=remove_comaint", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@modules, [qw/ + Module::Admin::Foo + /]) or note explain \@modules; + eq_or_diff(\@results, [ + 'Removed TESTUSER2 from co-maintainers of Module::Admin::Bar.', + ]); + } + if ($user eq 'TESTUSER') { + cmp_set(\@modules, [qw/ + Module::User::Foo + /]) or note explain \@modules; + eq_or_diff(\@results, [ + 'Removed TESTUSER2 from co-maintainers of Module::User::Bar.', + ]); + } + # note $t->content; + } +}; + +subtest 'broken tuple (not the owner)' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_share_perms_remocos_tuples => ['Module::Unrelated -- TESTUSER2'], + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=remove_comaint", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_set(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + /]) or note explain \@modules; + } + ok !@results; + eq_or_diff(\@errors, [ + 'You do not seem to be owner of Module::Unrelated.', + ]); + # note $t->content; + } +}; + +subtest 'broken tuple (not the comaint)' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @tuples; + if ($user eq 'TESTADMIN') { + @tuples = ( + 'Module::Admin::Bar -- TESTUSER4', + ); + } + if ($user eq 'TESTUSER') { + @tuples = ( + 'Module::User::Bar -- TESTUSER4', + ); + + } + + my %form = ( + %$default, + pause99_share_perms_remocos_tuples => \@tuples, + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=remove_comaint", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + eq_or_diff(\@errors, [ + 'Cannot handle tuple Module::Admin::Bar -- TESTUSER4. If you believe, this is a bug, please complain.' + ]); + } + if ($user eq 'TESTUSER') { + cmp_set(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + /]) or note explain \@modules; + eq_or_diff(\@errors, [ + 'Cannot handle tuple Module::User::Bar -- TESTUSER4. If you believe, this is a bug, please complain.' + ]); + } + ok !@results; + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/remove_dist_comaint.t b/t/pause_2025/action_2025/remove_dist_comaint.t new file mode 100644 index 000000000..db476fde3 --- /dev/null +++ b/t/pause_2025/action_2025/remove_dist_comaint.t @@ -0,0 +1,166 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_remove_dist_comaint_tuples => [], + SUBMIT_pause99_remove_dist_comaint => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=remove_dist_comaint"); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@dists, [qw/ + Module-Admin + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_set(\@dists, [qw/ + Module-User + /]) or note explain \@dists; + } + # note $t->content; + } +}; + +subtest 'normal case' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @tuples; + if ($user eq 'TESTADMIN') { + @tuples = ( + 'Module-Admin -- TESTUSER2', + ); + } + if ($user eq 'TESTUSER') { + @tuples = ( + 'Module-User -- TESTUSER2', + ); + } + + my %form = ( + %$default, + pause99_remove_dist_comaint_tuples => \@tuples, + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=remove_dist_comaint", \%form); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@dists, [qw/ + /]) or note explain \@dists; + eq_or_diff(\@results, [ + 'Removed TESTUSER2 from co-maintainers of Module::Admin::Bar (Module-Admin).', + 'Removed TESTUSER2 from co-maintainers of Module::Admin::Foo (Module-Admin).', + ]); + } + if ($user eq 'TESTUSER') { + cmp_set(\@dists, [qw/ + Module-User + /]) or note explain \@dists; + eq_or_diff(\@results, [ + 'Removed TESTUSER2 from co-maintainers of Module::User::Bar (Module-User).', + 'Removed TESTUSER2 from co-maintainers of Module::User::Foo (Module-User).', + ]); + } + # note $t->content; + } +}; + +subtest 'broken tuple (not an owner)' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_remove_dist_comaint_tuples => ['Module-Unrelated -- TESTUSER2'], + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=remove_dist_comaint", \%form); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@dists, [qw/ + Module-Admin + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_set(\@dists, [qw/ + Module-User + /]) or note explain \@dists; + } + ok !@results; + eq_or_diff(\@errors, [ + 'You do not seem to be owner of Module-Unrelated.', + ]); + # note $t->content; + } +}; + +subtest 'broken tuple (not a comaint)' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @tuples; + if ($user eq 'TESTADMIN') { + @tuples = ( + 'Module-Admin -- TESTUSER4', + ); + } + if ($user eq 'TESTUSER') { + @tuples = ( + 'Module-User -- TESTUSER4', + ); + + } + + my %form = ( + %$default, + pause99_remove_dist_comaint_tuples => \@tuples, + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=remove_dist_comaint", \%form); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @errors = map {$_->all_text} $t->dom->find('.error')->each; + if ($user eq 'TESTADMIN') { + cmp_set(\@dists, [qw/ + Module-Admin + /]) or note explain \@dists; + eq_or_diff(\@errors, [ + 'Cannot handle tuple Module-Admin -- TESTUSER4. If you believe, this is a bug, please complain.', + ]); + } + if ($user eq 'TESTUSER') { + cmp_set(\@dists, [qw/ + Module-User + /]) or note explain \@dists; + eq_or_diff(\@errors, [ + 'Cannot handle tuple Module-User -- TESTUSER4. If you believe, this is a bug, please complain.', + ]); + } + ok !@results; + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/remove_dist_primary.t b/t/pause_2025/action_2025/remove_dist_primary.t new file mode 100644 index 000000000..06d7c3342 --- /dev/null +++ b/t/pause_2025/action_2025/remove_dist_primary.t @@ -0,0 +1,134 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_remove_dist_primary_d => [], + SUBMIT_pause99_remove_dist_primary => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=remove_dist_primary"); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + Module-Admin + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + Module-User + Module-User-Foo-Baz + /]) or note explain \@dists; + } + # note $t->content; + } +}; + +subtest 'normal case' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @dists; + if ($user eq 'TESTADMIN') { + @dists = qw/Module-Admin/; + } + if ($user eq 'TESTUSER') { + @dists = qw/Module-User/; + } + + my %form = ( + %$default, + pause99_remove_dist_primary_d => \@dists, + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=remove_dist_primary", \%form); + @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + /]) or note explain \@dists; + eq_or_diff(\@results, [ + 'Removed primary maintainership of TESTADMIN from Module::Admin::Bar (Module-Admin).', + 'Removed primary maintainership of TESTADMIN from Module::Admin::Foo (Module-Admin).', + ]); + + # really transferred to ADOPTME? + $t->get_ok("$path?ACTION=peek_dist_perms", { + pause99_peek_dist_perms_query => "ADOPTME", + pause99_peek_dist_perms_by => "a", + pause99_peek_dist_perms_sub => 1, + }); + my @adoptme_dists = map {$_->all_text} $t->dom->find('td.dist')->each; + cmp_set(\@adoptme_dists, [qw/Module-Admin/]) or note explain \@adoptme_dists; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + Module-User-Foo-Baz + /]) or note explain \@dists; + eq_or_diff(\@results, [ + 'Removed primary maintainership of TESTUSER from Module::User::Bar (Module-User).', + 'Removed primary maintainership of TESTUSER from Module::User::Foo (Module-User).', + ]); + + # really transferred to ADOPTME? + $t->get_ok("$path?ACTION=peek_dist_perms", { + pause99_peek_dist_perms_query => "ADOPTME", + pause99_peek_dist_perms_by => "a", + pause99_peek_dist_perms_sub => 1, + }); + my @adoptme_dists = map {$_->all_text} $t->dom->find('td.dist')->each; + cmp_set(\@adoptme_dists, [qw/Module-User/]) or note explain \@adoptme_dists; + } + # note $t->content; + } +}; + +subtest 'unrelated dists' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_remove_dist_primary_d => [qw/Module-Unrelated/], + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=remove_dist_primary", \%form); + my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @warnings = map {$_->all_text} $t->dom->find('.warning')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@dists, [qw/ + Module-Admin + /]) or note explain \@dists; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@dists, [qw/ + Module-User + Module-User-Foo-Baz + /]) or note explain \@dists; + } + ok !@results; + eq_or_diff(\@warnings, [ + 'You need to select one or more distributions. Nothing done.', + ]); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/remove_primary.t b/t/pause_2025/action_2025/remove_primary.t new file mode 100644 index 000000000..e6f82d58d --- /dev/null +++ b/t/pause_2025/action_2025/remove_primary.t @@ -0,0 +1,138 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; +use Test::Deep; +use Test::Differences; + +my $default = { + pause99_share_perms_pr_m => [], + SUBMIT_pause99_share_perms_remopr => 1, +}; + +Test::PAUSE::Web->setup; +Test::PAUSE::Web->reset_module_fixture; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=remove_primary"); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + } + # note $t->content; + } +}; + +subtest 'normal case' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my @packages; + if ($user eq 'TESTADMIN') { + @packages = qw/Module::Admin::Bar/; + } + if ($user eq 'TESTUSER') { + @packages = qw/Module::User::Bar/; + } + + my %form = ( + %$default, + pause99_share_perms_pr_m => \@packages, + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=remove_primary", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Admin::Foo + /]) or note explain \@modules; + eq_or_diff(\@results, [ + 'Removed primary maintainership of TESTADMIN from Module::Admin::Bar.', + ]); + + # really transferred to ADOPTME? + $t->get_ok("$path?ACTION=peek_perms", { + pause99_peek_perms_query => "ADOPTME", + pause99_peek_perms_by => "a", + pause99_peek_perms_sub => 1, + }); + my @adoptme_modules = map {$_->all_text} $t->dom->find('td.module')->each; + cmp_set(\@adoptme_modules, [qw/Module::Admin::Bar/]) or note explain \@adoptme_modules; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + eq_or_diff(\@results, [ + 'Removed primary maintainership of TESTUSER from Module::User::Bar.', + ]); + + # really transferred to ADOPTME? + $t->get_ok("$path?ACTION=peek_perms", { + pause99_peek_perms_query => "ADOPTME", + pause99_peek_perms_by => "a", + pause99_peek_perms_sub => 1, + }); + my @adoptme_modules = map {$_->all_text} $t->dom->find('td.module')->each; + cmp_set(\@adoptme_modules, [qw/Module::User::Bar/]) or note explain \@adoptme_modules; + } + # note $t->content; + } +}; + +subtest 'unrelated modules' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = ( + %$default, + pause99_share_perms_pr_m => [qw/Module::Unrelated/], + ); + + Test::PAUSE::Web->reset_module_fixture; + $t->post_ok("$path?ACTION=remove_primary", \%form); + my @modules = map {$_->all_text} $t->dom->find('td.package')->each; + my @results = map {$_->all_text} $t->dom->find('.result')->each; + my @warnings = map {$_->all_text} $t->dom->find('.warning')->each; + if ($user eq 'TESTADMIN') { + cmp_bag(\@modules, [qw/ + Module::Admin::Bar + Module::Admin::Foo + /]) or note explain \@modules; + } + if ($user eq 'TESTUSER') { + cmp_bag(\@modules, [qw/ + Module::User::Bar + Module::User::Foo + Module::User::Foo::Baz + /]) or note explain \@modules; + } + ok !@results; + eq_or_diff(\@warnings, [ + 'You need to select one or more packages. Nothing done.', + ]); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/request_id.t b/t/pause_2025/action_2025/request_id.t new file mode 100644 index 000000000..8936d08bb --- /dev/null +++ b/t/pause_2025/action_2025/request_id.t @@ -0,0 +1,273 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +my $default = { + pause99_request_id_fullname => 'full name', + pause99_request_id_email => 'test@localhost.localdomain', + pause99_request_id_homepage => 'none', + pause99_request_id_userid => 'NEWUSER', + pause99_request_id_rationale => 'Hello, my ratoinale is to test PAUSE', + SUBMIT_pause99_request_id_sub => 1, +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=request_id"); + # note $t->content; + } +}; + +subtest 'post: basic' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = %$default; + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_like("pre.email_sent", qr/Subject: PAUSE ID request \(NEWUSER/); + is $t->deliveries => 2, "two deliveries (one for admin, one for requester)"; + # note $t->content; + } +}; + +subtest 'post: thank you, bot' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + url => 'http://host/path', + ); + $t->post_ok("$path?ACTION=request_id", \%form); + is $t->content => "Thank you!"; + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: no space in full name' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_fullname => 'FULLNAME', + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h3", "Error processing form") + ->text_like("ul.errors li", qr/Name does not look like a full civil name/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: no full name' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_fullname => '', + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h3", "Error processing form") + ->text_like("ul.errors li", qr/You must supply a name/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: no email' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_email => '', + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h3", "Error processing form") + ->text_like("ul.errors li", qr/You must supply an email address/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: invalid email' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_email => 'no email', + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h3", "Error processing form") + ->text_like("ul.errors li", qr/Your email address doesn't look like valid email address./); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: rational is too short' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_rationale => 'rationale', + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h3", "Error processing form") + ->text_like("ul.errors li", qr/this looks a\s+bit too short/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +# XXX: might be better to ignore other attributes (or YAGNI) +subtest 'post: rational has html links' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_rationale => '', + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h3", "Error processing form") + ->text_like("ul.errors li", qr/Please do not use HTML links/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: multiple links' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_rationale => <<'SPAM', +http://spam/path +http://spam/path +SPAM + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h3", "Error processing form") + ->text_like("ul.errors li", qr/Please do not include more than one URL/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: no rationale' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_rationale => '', + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h3", "Error processing form") + ->text_like("ul.errors li", qr/You must supply a short description/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: userid is taken' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_userid => 'TESTUSER', + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h3", "Error processing form") + ->text_like("ul.errors li", qr/The userid TESTUSER is already taken/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: invalid userid' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_userid => 'INV#LID', + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h3", "Error processing form") + ->text_like("ul.errors li", qr/The userid INV#LID does not match/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: no userid' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_userid => '', + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h3", "Error processing form") + ->text_like("ul.errors li", qr/You must supply a desired user-ID/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: lots of .info' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_rationale => <<'SPAM', +ttp://spam.info +ttp://spam.info +ttp://spam.info +ttp://spam.info +ttp://spam.info +SPAM + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h2", "Error") + ->text_like("p.error_message", qr/rationale looks like spam/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +subtest 'post: interesting .cn homepage' => sub { + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my %form = ( + %$default, + pause99_request_id_homepage => 'http://some.cn/index.htm', + pause99_request_id_rationale => 'interesting site', + ); + $t->post_ok("$path?ACTION=request_id", \%form) + ->text_is("h2", "Error") + ->text_like("p.error_message", qr/rationale looks like spam/); + ok !$t->deliveries, "no deliveries"; + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/reset_version.t b/t/pause_2025/action_2025/reset_version.t new file mode 100644 index 000000000..45c37dc89 --- /dev/null +++ b/t/pause_2025/action_2025/reset_version.t @@ -0,0 +1,48 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +my $default = { + pause99_reset_version_PKG => ["Foo"], + SUBMIT_pause99_reset_version_forget => 1, +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=reset_version"); + # note $t->content; + } +}; + +subtest 'post: basic' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->mod_dbh->do("TRUNCATE packages"); + $t->mod_db->insert('packages', { + package => "Foo", + version => "0.01", + dist => "T/TE/$user/Foo-0.01.tar.gz", + file => "Foo-0.01.tar.gz", + }); + $t->mod_db->insert('packages', { + package => "Bar", + version => "0.02", + dist => "T/TE/$user/Bar-0.02.tar.gz", + file => "Bar-0.02.tar.gz", + }); + + my %form = %$default; + $t->post_ok("$path?ACTION=reset_version", \%form); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/select_ml_action.t b/t/pause_2025/action_2025/select_ml_action.t new file mode 100644 index 000000000..75bda972b --- /dev/null +++ b/t/pause_2025/action_2025/select_ml_action.t @@ -0,0 +1,49 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +my $mailing_list = { + SUBMIT_pause99_add_user_Definitely => 1, + pause99_add_user_userid => "MAILLIST", + pause99_add_user_email => "ml\@localhost.localdomain", + pause99_add_user_subscribe => "how to subscribe", +}; + +my $default = { + HIDDENNAME => "TESTUSER", + ACTIONREQ => "edit_ml", + pause99_select_ml_action_sub => 1, +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=select_ml_action"); + # note $t->content; + } +}; + +subtest 'post: basic' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->post_ok("$path?ACTION=add_user", $mailing_list); + + $t->mod_db->insert("list2user", { + maillistid => "MAILLIST", + userid => "TESTUSER", + }, {ignore => 1}); + + my %form = %$default; + $t->post_ok("$path?ACTION=select_ml_action", \%form); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/select_user.t b/t/pause_2025/action_2025/select_user.t new file mode 100644 index 000000000..3d6ac280e --- /dev/null +++ b/t/pause_2025/action_2025/select_user.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=select_user"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/share_perms.t b/t/pause_2025/action_2025/share_perms.t new file mode 100644 index 000000000..76c4be7bf --- /dev/null +++ b/t/pause_2025/action_2025/share_perms.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=share_perms"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/show_files.t b/t/pause_2025/action_2025/show_files.t new file mode 100644 index 000000000..9c6b61797 --- /dev/null +++ b/t/pause_2025/action_2025/show_files.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=show_files"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/show_ml_repr.t b/t/pause_2025/action_2025/show_ml_repr.t new file mode 100644 index 000000000..2fc8bce41 --- /dev/null +++ b/t/pause_2025/action_2025/show_ml_repr.t @@ -0,0 +1,18 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=show_ml_repr"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/tail_logfile.t b/t/pause_2025/action_2025/tail_logfile.t new file mode 100644 index 000000000..49bb91888 --- /dev/null +++ b/t/pause_2025/action_2025/tail_logfile.t @@ -0,0 +1,43 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +my $default = { + pause99_tail_logfile_1 => 5000, + pause99_tail_logfile_sub => 1, +}; + +Test::PAUSE::Web->setup; + +{ + open my $fh, '>', $PAUSE::Config->{PAUSE_LOG}; + say $fh < sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("/pause/authenquery?ACTION=tail_logfile"); + # note $t->content; + } +}; + +subtest 'post: basic' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + my %form = %$default; + $t->post_ok("$path?ACTION=tail_logfile", \%form); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/who_admin.t b/t/pause_2025/action_2025/who_admin.t new file mode 100644 index 000000000..f8a41cb07 --- /dev/null +++ b/t/pause_2025/action_2025/who_admin.t @@ -0,0 +1,44 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use YAML::Syck (); + +Test::PAUSE::Web->setup; + +# SELECT user FROM grouptable WHERE ugroup='admin' order by user"); +subtest 'get' => sub { + Test::PAUSE::Web->authen_db->insert('grouptable', { + user => "FOO", + ugroup => "admin", + }); + Test::PAUSE::Web->authen_db->insert('grouptable', { + user => "BAR", + ugroup => "admin", + }); + Test::PAUSE::Web->authen_db->insert('grouptable', { + user => "BAZ", + ugroup => "bar", + }); + + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->get_ok("$path?ACTION=who_admin") + ->text_like('body', qr/Registered admins:\s+BAR, FOO/); + + $t->get_ok("$path?ACTION=who_admin&OF=YAML"); + my $list_amp = YAML::Syck::Load( $t->content ); + is_deeply( $list_amp, [qw/BAR FOO TESTADMIN/], "YAML output works" ); + + SKIP: { + skip "; is not supported anymore", 1; + $t->get_ok("$path?ACTION=who_admin;OF=YAML"); + my $list_sem = YAML::Syck::Load( $t->content ); + is_deeply( $list_sem, [qw/BAR FOO TESTADMIN/], "YAML output works" ); + } + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/who_pumpkin.t b/t/pause_2025/action_2025/who_pumpkin.t new file mode 100644 index 000000000..4e60d2bc5 --- /dev/null +++ b/t/pause_2025/action_2025/who_pumpkin.t @@ -0,0 +1,44 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use YAML::Syck (); + +Test::PAUSE::Web->setup; + +# SELECT user FROM grouptable WHERE ugroup='pumpking' order by user"); +subtest 'get' => sub { + Test::PAUSE::Web->authen_db->insert('grouptable', { + user => "FOO", + ugroup => "pumpking", + }); + Test::PAUSE::Web->authen_db->insert('grouptable', { + user => "BAR", + ugroup => "pumpking", + }); + Test::PAUSE::Web->authen_db->insert('grouptable', { + user => "BAZ", + ugroup => "baz", + }); + + for my $test (Test::PAUSE::Web->tests_for('public')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + + $t->get_ok("$path?ACTION=who_pumpkin") + ->text_like("body", qr/Registered pumpkins:\s+BAR, FOO/); + + $t->get_ok("$path?ACTION=who_pumpkin&OF=YAML"); + my $list_amp = YAML::Syck::Load( $t->content ); + is_deeply( $list_amp, [qw/BAR FOO/], "YAML output works" ); + + SKIP: { + skip "; is not supported anymore", 1; + $t->get_ok("$path?ACTION=who_pumpkin;OF=YAML"); + my $list_sem = YAML::Syck::Load( $t->content ); + is_deeply( $list_sem, [qw/BAR FOO/], "YAML output works" ); + } + } +}; + +done_testing; From 69e64ee0b73d66ea42a2ecc135c8484ce47c0567 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Fri, 2 May 2025 16:32:00 +0900 Subject: [PATCH 43/51] Migrate pause_2025 tests --- t/pause_2025/00_load.t | 4 +- t/pause_2025/action_2025/add_uri.t | 84 +++++++--- t/pause_2025/action_2025/add_user.t | 56 ++++--- t/pause_2025/action_2025/change_passwd.t | 62 +++++--- t/pause_2025/action_2025/delete_files.t | 58 ++++--- t/pause_2025/action_2025/edit_cred.t | 20 ++- t/pause_2025/action_2025/edit_ml.t | 5 +- t/pause_2025/action_2025/edit_uris.t | 12 +- t/pause_2025/action_2025/email_for_admin.t | 19 ++- t/pause_2025/action_2025/giveup_comaint.t | 15 +- .../action_2025/giveup_dist_comaint.t | 15 +- t/pause_2025/action_2025/mailpw.t | 52 ++++--- t/pause_2025/action_2025/make_comaint.t | 21 +-- t/pause_2025/action_2025/make_dist_comaint.t | 20 ++- t/pause_2025/action_2025/manage_id_requests.t | 5 +- t/pause_2025/action_2025/move_dist_primary.t | 20 ++- t/pause_2025/action_2025/move_primary.t | 20 ++- t/pause_2025/action_2025/pause_04about.t | 5 +- t/pause_2025/action_2025/pause_04imprint.t | 5 +- t/pause_2025/action_2025/pause_05news.t | 5 +- t/pause_2025/action_2025/pause_06history.t | 5 +- .../action_2025/pause_namingmodules.t | 5 +- .../action_2025/pause_operating_model.t | 5 +- .../action_2025/pause_privacy_policy.t | 5 +- t/pause_2025/action_2025/peek_dist_perms.t | 26 ++-- t/pause_2025/action_2025/peek_perms.t | 26 ++-- t/pause_2025/action_2025/reindex.t | 12 +- t/pause_2025/action_2025/remove_comaint.t | 20 ++- .../action_2025/remove_dist_comaint.t | 20 ++- .../action_2025/remove_dist_primary.t | 19 ++- t/pause_2025/action_2025/remove_primary.t | 19 ++- t/pause_2025/action_2025/request_id.t | 80 ++++++---- t/pause_2025/action_2025/reset_version.t | 10 +- t/pause_2025/action_2025/select_ml_action.t | 14 +- t/pause_2025/action_2025/select_user.t | 5 +- t/pause_2025/action_2025/share_perms.t | 5 +- t/pause_2025/action_2025/show_files.t | 5 +- t/pause_2025/action_2025/show_ml_repr.t | 5 +- t/pause_2025/action_2025/tail_logfile.t | 10 +- t/pause_2025/action_2025/who_admin.t | 14 +- t/pause_2025/action_2025/who_pumpkin.t | 14 +- t/pause_2025/auth.t | 147 ++++++++++++------ t/pause_2025/lib/Test/PAUSE/Web.pm | 34 +++- t/pause_2025/logout.t | 76 +++++---- 44 files changed, 675 insertions(+), 409 deletions(-) diff --git a/t/pause_2025/00_load.t b/t/pause_2025/00_load.t index 1b32717c9..be3dfbf20 100644 --- a/t/pause_2025/00_load.t +++ b/t/pause_2025/00_load.t @@ -10,11 +10,11 @@ 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_2017"); + my $path = $file->relative("$Test::PAUSE::Web::AppRoot/lib/pause_2025"); $path =~ s|\.pm$|| or return; $path =~ s|/|::|g; use_ok($path); -}, no_chdir => 1}, "$Test::PAUSE::Web::AppRoot/lib/pause_2017/PAUSE"); +}, no_chdir => 1}, "$Test::PAUSE::Web::AppRoot/lib/pause_2025/PAUSE"); done_testing; diff --git a/t/pause_2025/action_2025/add_uri.t b/t/pause_2025/action_2025/add_uri.t index 5d1c22f66..5d8901105 100644 --- a/t/pause_2025/action_2025/add_uri.t +++ b/t/pause_2025/action_2025/add_uri.t @@ -22,8 +22,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=add_uri"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("user/add_uri"); # note $t->content; } }; @@ -36,8 +37,9 @@ subtest 'get: user with subdirs' => sub { $subdir->make_path; $subdir->child("stuff.txt")->spew("Foo"); - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=add_uri"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/add_uri"); $t->text_is('select[name="pause99_add_uri_subdirscrl"] option[value="."]', "."); # default $t->text_is('select[name="pause99_add_uri_subdirscrl"] option[value="test"]', "test"); # note $t->content; @@ -47,13 +49,14 @@ subtest 'get: user with subdirs' => sub { subtest 'post: basic' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = %$http_upload; my $file = $PAUSE::Config->{INCOMING_LOC}."/".$form{pause99_add_uri_httpupload}[1]; ok !-f $file, "file to upload does not exist"; $t->mod_dbh->do('TRUNCATE uris'); - $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + $t->post_ok("/user/add_uri", \%form, "Content-Type" => "form-data"); # note $t->content; ok -f $file, "uploaded file exists"; @@ -70,7 +73,8 @@ subtest 'post: basic' => sub { subtest 'post: under a new subdir' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = %$http_upload; $form{pause99_add_uri_subdirtext} = "new_dir"; @@ -78,7 +82,7 @@ subtest 'post: under a new subdir' => sub { ok !-f $file, "file to upload does not exist"; $t->mod_dbh->do('TRUNCATE uris'); - $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + $t->post_ok("/user/add_uri", \%form, "Content-Type" => "form-data"); # note $t->content; ok -f $file, "uploaded file exists"; @@ -96,7 +100,8 @@ subtest 'post: under a new subdir' => sub { subtest 'post: under a Perl6 subdir' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = %$http_upload; $form{pause99_add_uri_subdirscrl} = "Perl6"; @@ -109,7 +114,7 @@ subtest 'post: under a Perl6 subdir' => sub { ok !-f $file, "file to upload does not exist"; $t->mod_dbh->do('TRUNCATE uris'); - $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + $t->post_ok("/user/add_uri", \%form, "Content-Type" => "form-data"); # note $t->content; ok -f $file, "uploaded file exists"; @@ -125,15 +130,38 @@ subtest 'post: under a Perl6 subdir' => sub { } }; +subtest 'post: move error' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + my %form = %$http_upload; + rmtree($PAUSE::Config->{INCOMING_LOC}); + + $t->mod_dbh->do('TRUNCATE uris'); + $t->post_ok("/user/add_uri", \%form, "Content-Type" => "form-data"); + $t->text_like('.error_message' => qr/Couldn't copy file/); + + my $rows = $t->mod_db->select('uris', ['*'], { + userid => $user, + uri => $form{pause99_add_uri_httpupload}[1], + }); + is @$rows => 0; + + mkpath($PAUSE::Config->{INCOMING_LOC}); + } +}; + subtest 'post: empty' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = %$http_upload; $form{pause99_add_uri_httpupload} = [undef, 'index.html']; $t->mod_dbh->do('TRUNCATE uris'); - $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + $t->post_ok("/user/add_uri", \%form, "Content-Type" => "form-data"); # note $t->content; my $rows = $t->mod_db->select('uris', ['*'], { @@ -147,14 +175,15 @@ subtest 'post: empty' => sub { subtest 'post: renamed' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = %$http_upload; $form{pause99_add_uri_httpupload} = ["$Test::PAUSE::Web::AppRoot/htdocs/index.html", 'html/index.html']; my $file = $PAUSE::Config->{INCOMING_LOC}."/index.html"; ok !-f $file, "file to upload does not exist"; $t->mod_dbh->do('TRUNCATE uris'); - $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + $t->post_ok("/user/add_uri", \%form, "Content-Type" => "form-data"); # note $t->content; # renamed file exists @@ -172,11 +201,12 @@ subtest 'post: renamed' => sub { subtest 'post: uri' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = %$uri_upload; $t->mod_dbh->do('TRUNCATE uris'); - $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + $t->post_ok("/user/add_uri", \%form, "Content-Type" => "form-data"); # note $t->content; my $rows = $t->mod_db->select('uris', ['*'], { @@ -190,12 +220,13 @@ subtest 'post: uri' => sub { subtest 'post: CHECKSUMS' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = %$http_upload; $form{pause99_add_uri_httpupload} = ["$Test::PAUSE::Web::AppRoot/htdocs/index.html", "CHECKSUMS"], $t->mod_dbh->do('TRUNCATE uris'); - $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + $t->post_ok("/user/add_uri", \%form, "Content-Type" => "form-data"); $t->text_like('.error_message' => qr/Files with the name CHECKSUMS cannot be/); # note $t->content; @@ -210,14 +241,15 @@ subtest 'post: CHECKSUMS' => sub { subtest 'post: allow overwrite' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = %$http_upload; my $file = $PAUSE::Config->{INCOMING_LOC}."/".$form{pause99_add_uri_httpupload}[1]; ok !-f $file, "file to upload does not exists"; $t->mod_dbh->do('TRUNCATE uris'); for (0 .. 1) { - $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + $t->post_ok("/user/add_uri", \%form, "Content-Type" => "form-data"); # note $t->content; # uploaded file exists @@ -236,14 +268,15 @@ subtest 'post: allow overwrite' => sub { subtest 'post: duplicate' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = %$http_upload; $form{pause99_add_uri_httpupload} = ["$Test::PAUSE::Web::AppRoot/htdocs/index.html", "index.tar.gz"], my $file = $PAUSE::Config->{INCOMING_LOC}."/".$form{pause99_add_uri_httpupload}[1]; ok !-f $file, "file to upload does not exist"; $t->mod_dbh->do('TRUNCATE uris'); - $t->post_ok("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + $t->post_ok("/user/add_uri", \%form, "Content-Type" => "form-data"); # note $t->content; ok -f $file, "uploaded file exists"; @@ -255,7 +288,7 @@ subtest 'post: duplicate' => sub { }); is @$rows => 1; - my $res = $t->post("$path?ACTION=add_uri", \%form, "Content-Type" => "form-data"); + my $res = $t->post("/user/add_uri", \%form, "Content-Type" => "form-data"); is $res->code => 409; # note $t->content; @@ -273,13 +306,14 @@ subtest 'post: duplicate' => sub { subtest 'post: to the site top, as various CPAN uploaders do/did' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = %$http_upload; my $file = $PAUSE::Config->{INCOMING_LOC}."/".$form{pause99_add_uri_httpupload}[1]; ok !-f $file, "file to upload does not exist"; $t->mod_dbh->do('TRUNCATE uris'); - $t->post_ok("$path", \%form, "Content-Type" => "form-data"); + $t->post_ok("/", \%form, "Content-Type" => "form-data"); # note $t->content; ok -f $file, "uploaded file exists"; diff --git a/t/pause_2025/action_2025/add_user.t b/t/pause_2025/action_2025/add_user.t index 0912d03a3..500df039e 100644 --- a/t/pause_2025/action_2025/add_user.t +++ b/t/pause_2025/action_2025/add_user.t @@ -31,8 +31,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('admin')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=add_user"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/admin/add_user"); # note $t->content; } }; @@ -40,10 +41,11 @@ subtest 'get' => sub { subtest 'post: ordinary user' => sub { for my $test (Test::PAUSE::Web->tests_for('admin')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); $t->reset_fixture; - $t->post_ok("$path?ACTION=add_user", $new_user); + $t->post_ok("/admin/add_user", $new_user); # note $t->content; # new user exists @@ -72,10 +74,11 @@ subtest 'post: ordinary user' => sub { subtest 'post: user with an accent in their name' => sub { for my $test (Test::PAUSE::Web->tests_for('admin')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); $t->reset_fixture; - $t->post_ok("$path?ACTION=add_user", { + $t->post_ok("/admin/add_user", { %$new_user, pause99_add_user_fullname => "T\xc3\xa9st Name", }); @@ -96,7 +99,8 @@ subtest 'post: user with an accent in their name' => sub { subtest 'post: soundex' => sub { for my $test (Test::PAUSE::Web->tests_for('admin')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %copied_user = %$new_user; $copied_user{pause99_add_user_fullname} = 'new user'; @@ -104,7 +108,7 @@ subtest 'post: soundex' => sub { delete $copied_user{SUBMIT_pause99_add_user_Definitely}; $t->reset_fixture; - $t->post_ok("$path?ACTION=add_user", { + $t->post_ok("/admin/add_user", { %copied_user, }); # note $t->content; @@ -120,7 +124,8 @@ subtest 'post: soundex' => sub { subtest 'post: soundex error: similar name' => sub { for my $test (Test::PAUSE::Web->tests_for('admin')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %copied_user = %$new_user; $copied_user{pause99_add_user_fullname} = 'new nome'; @@ -128,7 +133,7 @@ subtest 'post: soundex error: similar name' => sub { delete $copied_user{SUBMIT_pause99_add_user_Definitely}; $t->reset_fixture; - $t->post_ok("$path?ACTION=add_user", { + $t->post_ok("/admin/add_user", { %copied_user, }); $t->text_like('h3', qr/Not submitting NEWUSER, maybe we have a duplicate/); @@ -145,7 +150,8 @@ subtest 'post: soundex error: similar name' => sub { subtest 'post: metaphone' => sub { for my $test (Test::PAUSE::Web->tests_for('admin')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %copied_user = %$new_user; $copied_user{pause99_add_user_fullname} = 'new user'; @@ -153,7 +159,7 @@ subtest 'post: metaphone' => sub { delete $copied_user{SUBMIT_pause99_add_user_Definitely}; $t->reset_fixture; - $t->post_ok("$path?ACTION=add_user", { + $t->post_ok("/admin/add_user", { %copied_user, }); # note $t->content; @@ -169,7 +175,8 @@ subtest 'post: metaphone' => sub { subtest 'post: metaphone error: similar name' => sub { for my $test (Test::PAUSE::Web->tests_for('admin')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %copied_user = %$new_user; $copied_user{pause99_add_user_fullname} = 'new nome'; @@ -177,7 +184,7 @@ subtest 'post: metaphone error: similar name' => sub { delete $copied_user{SUBMIT_pause99_add_user_Definitely}; $t->reset_fixture; - $t->post_ok("$path?ACTION=add_user", { + $t->post_ok("/admin/add_user", { %copied_user, }); $t->text_like('h3', qr/Not submitting NEWUSER, maybe we have a duplicate/); @@ -194,14 +201,15 @@ subtest 'post: metaphone error: similar name' => sub { subtest 'post: metaphone error: completely duplicated' => sub { for my $test (Test::PAUSE::Web->tests_for('admin')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %copied_user = %$new_user; $copied_user{SUBMIT_pause99_add_user_Metaphone} = 1; delete $copied_user{SUBMIT_pause99_add_user_Definitely}; $t->reset_fixture; - $t->post_ok("$path?ACTION=add_user", { + $t->post_ok("/admin/add_user", { %copied_user, }); @@ -211,7 +219,7 @@ subtest 'post: metaphone error: completely duplicated' => sub { }); is @$rows => 1; - $t->post_ok("$path?ACTION=add_user", { + $t->post_ok("/admin/add_user", { %copied_user, }); $t->text_like('h3', qr/Not submitting NEWUSER, maybe we have a duplicate/); @@ -222,10 +230,11 @@ subtest 'post: metaphone error: completely duplicated' => sub { subtest 'post: mailing list' => sub { for my $test (Test::PAUSE::Web->tests_for('admin')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); $t->reset_fixture; - $t->post_ok("$path?ACTION=add_user", $new_mailing_list); + $t->post_ok("/admin/add_user", $new_mailing_list); # note $t->content; # new mailing list exists @@ -245,7 +254,8 @@ subtest 'post: mailing list' => sub { subtest 'get: retrieve a stored session' => sub { for my $test (Test::PAUSE::Web->tests_for('admin')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %requested_user; for my $key (keys %$new_user) { @@ -257,13 +267,13 @@ subtest 'get: retrieve a stored session' => sub { $requested_user{SUBMIT_pause99_request_id_sub} = 1; $t->reset_fixture; - $t->post_ok("$path?ACTION=request_id", \%requested_user); + $t->post_ok("/public/request_id", \%requested_user); my ($email) = map {$_->body} $t->deliveries; - my ($userid) = $email =~ m!https://.+?/pause/authenquery.+?USERID=([^&\s]+)!; + my ($userid) = $email =~ m!https://.+?/admin/add_user\?USERID=([^&\s]+)!; like $userid => qr/\A\d+_\w+\z/; $t->clear_deliveries; - $t->get_ok("$path?ACTION=add_user&USERID=$userid"); + $t->get_ok("/admin/add_user\?USERID=$userid"); # note $t->content; for my $key (keys %$new_user) { diff --git a/t/pause_2025/action_2025/change_passwd.t b/t/pause_2025/action_2025/change_passwd.t index c447fb14c..95168ecc2 100644 --- a/t/pause_2025/action_2025/change_passwd.t +++ b/t/pause_2025/action_2025/change_passwd.t @@ -16,8 +16,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=change_passwd"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/change_passwd"); # note $t->content; } }; @@ -26,9 +27,10 @@ subtest 'get: public without ABRA' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; next if $user; # public only - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); $t->authen_dbh->do('TRUNCATE abrakadabra'); - my $res = $t->get("$path?ACTION=change_passwd"); + my $res = $t->get("/public/change_passwd"); is $res->code => 403; # note $t->content; } @@ -38,7 +40,8 @@ subtest 'get: public with ABRA' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; next if $user; # public only - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my $chuser = 'TESTUSER'; my $chpass = 'testpassword'; @@ -49,7 +52,7 @@ subtest 'get: public with ABRA' => sub { expires => Time::Piece->new(time + 3600)->strftime('%Y-%m-%d %H:%M:%S'), }); - $t->get_ok("$path?ACTION=change_passwd&ABRA=$chuser.$chpass"); + $t->get_ok("/public/change_passwd?ABRA=$chuser.$chpass"); # note $t->content; # No links should keep ABRA (71a745d) @@ -63,8 +66,9 @@ subtest 'post: basic' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; my %form = %$default; - my $t = Test::PAUSE::Web->new(user => $user); - my $res = $t->post("$path?ACTION=change_passwd", \%form); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + my $res = $t->post("/user/change_passwd", \%form); ok !$res->is_success && $res->code == 403, "Forbidden"; like $res->content => qr/Failed CSRF check/; # note $t->content; @@ -76,8 +80,9 @@ subtest 'post_with_token: basic' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; my %form = %$default; - my $t = Test::PAUSE::Web->new(user => $user); - $t->post_with_token_ok("$path?ACTION=change_passwd", \%form) + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->post_with_token_ok("/user/change_passwd", \%form) ->text_like("p.password_stored", qr/New password stored/); is $t->deliveries => 1, "one delivery for admin"; # note $t->content; @@ -91,8 +96,9 @@ subtest 'post_with_token: user with CENSORED email' => sub { $user = "TESTCNSRD" if $user eq "TESTUSER"; my %form = %$default; - my $t = Test::PAUSE::Web->new(user => $user); - $t->post_with_token_ok("$path?ACTION=change_passwd", \%form) + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->post_with_token_ok("/user/change_passwd", \%form) ->text_like("p.password_stored", qr/New password stored/); my @deliveries = $t->deliveries; is @deliveries => 1, "one delivery for admin"; @@ -109,11 +115,12 @@ subtest 'post_with_token: public without ABRA' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; next if $user; # public only - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); $t->authen_dbh->do('TRUNCATE abrakadabra'); my %form = %$default; - my $res = $t->post_with_token("$path?ACTION=change_passwd", \%form); + my $res = $t->post_with_token("/public/change_passwd", \%form); is $res->code => 403; # note $t->content; } @@ -123,7 +130,8 @@ subtest 'post_with_token: public with ABRA' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; next if $user; # public only - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my $chuser = 'TESTUSER'; my $chpass = 'testpassword'; @@ -135,7 +143,7 @@ subtest 'post_with_token: public with ABRA' => sub { }); my %form = %$default; - $t->post_with_token_ok("$path?ACTION=change_passwd&ABRA=$chuser.$chpass", \%form); + $t->post_with_token_ok("/public/change_passwd?ABRA=$chuser.$chpass", \%form); $t->text_like("p.password_stored", qr/New password stored/); # note $t->content; @@ -144,7 +152,7 @@ subtest 'post_with_token: public with ABRA' => sub { ok !grep {$_ =~ /ABRA=/} @links; # Used ABRA is gone (8234a6a) - my $res = $t->post_with_token("$path?ACTION=change_passwd&ABRA=$chuser.$chpass", \%form); + my $res = $t->post_with_token("/public/change_passwd?ABRA=$chuser.$chpass", \%form); ok !$res->is_success; is $res->code => 401; } @@ -154,7 +162,8 @@ subtest 'post_with_token: public with incorrect ABRA' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; next if $user; # public only - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my $chuser = 'TESTUSER'; my $chpass = 'testpassword'; @@ -166,7 +175,7 @@ subtest 'post_with_token: public with incorrect ABRA' => sub { }); my %form = %$default; - my $res = $t->post_with_token("$path?ACTION=change_passwd&ABRA=$chuser.wrong$chpass", \%form); + my $res = $t->post_with_token("/public/change_passwd?ABRA=$chuser.wrong$chpass", \%form); is $res->code => 401; # note $t->content; } @@ -176,12 +185,13 @@ subtest 'post_with_token: passwords mismatch' => sub { Test::PAUSE::Web->setup; for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_change_passwd_pw2 => "wrong_pass", ); - $t->post_with_token_ok("$path?ACTION=change_passwd", \%form) + $t->post_with_token_ok("/user/change_passwd", \%form) ->text_is("h2", "Error") ->text_like("p.error_message", qr/The two passwords didn't match./); ok !$t->deliveries, "no delivery for admin"; @@ -193,12 +203,13 @@ subtest 'post_with_token: only one password' => sub { Test::PAUSE::Web->setup; for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_change_passwd_pw2 => undef, ); - $t->post_with_token_ok("$path?ACTION=change_passwd", \%form) + $t->post_with_token_ok("/user/change_passwd", \%form) ->text_is("h2", "Error") ->text_like("p.error_message", qr/You need to fill in the same password in both fields./); ok !$t->deliveries, "no delivery for admin"; @@ -210,13 +221,14 @@ subtest 'post_with_token: no password' => sub { Test::PAUSE::Web->setup; for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_change_passwd_pw1 => undef, pause99_change_passwd_pw2 => undef, ); - $t->post_with_token_ok("$path?ACTION=change_passwd", \%form) + $t->post_with_token_ok("/user/change_passwd", \%form) ->text_is("h2", "Error") ->text_like("p.error_message", qr/Please fill in the form with passwords./); ok !$t->deliveries, "no delivery for admin"; diff --git a/t/pause_2025/action_2025/delete_files.t b/t/pause_2025/action_2025/delete_files.t index 07ea06525..7c6e03197 100644 --- a/t/pause_2025/action_2025/delete_files.t +++ b/t/pause_2025/action_2025/delete_files.t @@ -18,8 +18,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=delete_files"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/delete_files"); # note $t->content; } }; @@ -27,27 +28,28 @@ subtest 'get' => sub { subtest 'post: basic' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); $t->mod_dbh->do("TRUNCATE uris"); $t->mod_dbh->do("TRUNCATE deletes"); $t->remove_authors_dir($user); # prepare distribution - $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + $t->post_ok("/user/add_uri", $default_for_add_uri, "Content-Type" => "form-data"); $t->copy_to_authors_dir($user, scalar Test::PAUSE::Web->file_to_upload); # delete my %form = %$default; $form{SUBMIT_pause99_delete_files_delete} = 1; - $t->post_ok("$path?ACTION=delete_files", \%form); + $t->post_ok("/user/delete_files", \%form); # note $t->content; my @deliveries = $t->deliveries; is @deliveries => 2; my ($mail_body) = map {$_->body} @deliveries; - like $mail_body => qr/ACTION=delete_files/; + like $mail_body => qr!/user/delete_files!; my $rows = $t->mod_db->select('deletes', ['*']); is @$rows => 1; @@ -56,7 +58,7 @@ subtest 'post: basic' => sub { # undelete delete $form{SUBMIT_pause99_delete_files_delete}; $form{SUBMIT_pause99_delete_files_undelete} = 1; - $t->post_ok("$path?ACTION=delete_files", \%form); + $t->post_ok("/user/delete_files", \%form); # note $t->content; ok $rows = $t->mod_db->select('deletes', ['*']); @@ -67,14 +69,15 @@ subtest 'post: basic' => sub { subtest 'post: absolute path' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); $t->mod_dbh->do("TRUNCATE uris"); $t->mod_dbh->do("TRUNCATE deletes"); $t->remove_authors_dir($user); # prepare distribution - $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + $t->post_ok("/user/add_uri", $default_for_add_uri, "Content-Type" => "form-data"); my $copied = $t->copy_to_authors_dir($user, scalar Test::PAUSE::Web->file_to_upload); ok(File::Spec->file_name_is_absolute($copied)); @@ -84,7 +87,7 @@ subtest 'post: absolute path' => sub { pause99_delete_files_FILE => [$copied], SUBMIT_pause99_delete_files_delete => 1 ); - $t->post_ok("$path?ACTION=delete_files", \%form); + $t->post_ok("/user/delete_files", \%form); # note $t->content; my @deliveries = $t->deliveries; @@ -100,14 +103,15 @@ subtest 'post: absolute path' => sub { subtest 'post: file not found' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); $t->mod_dbh->do("TRUNCATE uris"); $t->mod_dbh->do("TRUNCATE deletes"); $t->remove_authors_dir($user); # prepare distribution - $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + $t->post_ok("/user/add_uri", $default_for_add_uri, "Content-Type" => "form-data"); my $copied = $t->copy_to_authors_dir($user, scalar Test::PAUSE::Web->file_to_upload); @@ -116,7 +120,7 @@ subtest 'post: file not found' => sub { pause99_delete_files_FILE => ['Something-Else-0.02.tar.gz'], SUBMIT_pause99_delete_files_delete => 1 ); - $t->post_ok("$path?ACTION=delete_files", \%form); + $t->post_ok("/user/delete_files", \%form); # note $t->content; my @deliveries = $t->deliveries; @@ -132,14 +136,15 @@ subtest 'post: file not found' => sub { subtest 'post: CHECKSUMS' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); $t->mod_dbh->do("TRUNCATE uris"); $t->mod_dbh->do("TRUNCATE deletes"); $t->remove_authors_dir($user); # prepare distribution - $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + $t->post_ok("/user/add_uri", $default_for_add_uri, "Content-Type" => "form-data"); my $copied = $t->copy_to_authors_dir($user, scalar Test::PAUSE::Web->file_to_upload); $t->save_to_authors_dir($user, "CHECKSUMS", "CHECKSUMS"); @@ -149,7 +154,7 @@ subtest 'post: CHECKSUMS' => sub { pause99_delete_files_FILE => ['CHECKSUMS'], SUBMIT_pause99_delete_files_delete => 1 ); - $t->post_ok("$path?ACTION=delete_files", \%form); + $t->post_ok("/user/delete_files", \%form); # note $t->content; my @deliveries = $t->deliveries; @@ -165,14 +170,15 @@ subtest 'post: CHECKSUMS' => sub { subtest 'post: readme' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); $t->mod_dbh->do("TRUNCATE uris"); $t->mod_dbh->do("TRUNCATE deletes"); $t->remove_authors_dir($user); # prepare distribution - $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + $t->post_ok("/user/add_uri", $default_for_add_uri, "Content-Type" => "form-data"); my $copied = $t->copy_to_authors_dir($user, scalar Test::PAUSE::Web->file_to_upload); $t->save_to_authors_dir($user, "Hash-RenameKey-0.02.readme", "README"); @@ -180,7 +186,7 @@ subtest 'post: readme' => sub { # delete my %form = %$default; $form{SUBMIT_pause99_delete_files_delete} = 1; - $t->post_ok("$path?ACTION=delete_files", \%form); + $t->post_ok("/user/delete_files", \%form); # note $t->content; # .readme is deleted when a related tarball is removed @@ -199,41 +205,43 @@ subtest 'post: delete by admin using select_user' => sub { { my $test = Test::PAUSE::Web->tests_for('user'); my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); $t->mod_dbh->do("TRUNCATE uris"); $t->mod_dbh->do("TRUNCATE deletes"); $t->remove_authors_dir($user); # prepare distribution - $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + $t->post_ok("/user/add_uri", $default_for_add_uri, "Content-Type" => "form-data"); my $copied = $t->copy_to_authors_dir($user, scalar Test::PAUSE::Web->file_to_upload); } { my $test = Test::PAUSE::Web->tests_for('admin'); my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %action_form = ( HIDDENNAME => "TESTUSER", ACTIONREQ => "delete_files", pause99_select_user_sub => 1, ); - $t->post_ok("$path?ACTION=select_user", \%action_form); + $t->post_ok("/admin/select_user", \%action_form); # note $t->content; # delete my %form = %$default; $form{SUBMIT_pause99_delete_files_delete} = 1; $form{HIDDENNAME} = "TESTUSER"; - $t->post_ok("$path?ACTION=delete_files", \%form); + $t->post_ok("/user/delete_files", \%form); # note $t->content; my @deliveries = $t->deliveries; is @deliveries => 3; # for TESTUSER, TESTADMIN, pause_admin my ($mail_body) = map {$_->body} @deliveries; - like $mail_body => qr/ACTION=delete_files/; + like $mail_body => qr!/user/delete_files!; my $rows = $t->mod_db->select('deletes', ['*']); is @$rows => 1; diff --git a/t/pause_2025/action_2025/edit_cred.t b/t/pause_2025/action_2025/edit_cred.t index 507859f8f..83d9ae42e 100644 --- a/t/pause_2025/action_2025/edit_cred.t +++ b/t/pause_2025/action_2025/edit_cred.t @@ -18,8 +18,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=edit_cred"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/edit_cred"); # note $t->content; } }; @@ -28,10 +29,11 @@ subtest 'post: basic' => sub { plan skip_all => 'SKIP for now'; for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = %$default; - $t->post_ok("$path?ACTION=edit_cred", \%form); + $t->post_ok("/user/edit_cred", \%form); # note $t->content; } }; @@ -39,10 +41,11 @@ subtest 'post: basic' => sub { subtest 'post_with_token: basic' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = %$default; - $t->post_with_token_ok("$path?ACTION=edit_cred", \%form); + $t->post_with_token_ok("/user/edit_cred", \%form); # note $t->content; } }; @@ -50,12 +53,13 @@ subtest 'post_with_token: basic' => sub { subtest 'post_with_token: edit with CENSORED email' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); Test::PAUSE::Web->setup; $t->mod_db->update('users', { email => 'CENSORED' }, { userid => $user }); my %form = (%$default, pause99_edit_cred_email => 'CENSORED'); - $t->post_with_token_ok("$path?ACTION=edit_cred", \%form); + $t->post_with_token_ok("/user/edit_cred", \%form); my @deliveries = $t->deliveries; like $deliveries[0]->as_string => qr/\[CENSORED\]/; # note $t->content; diff --git a/t/pause_2025/action_2025/edit_ml.t b/t/pause_2025/action_2025/edit_ml.t index 535653cd9..ec8187fa9 100644 --- a/t/pause_2025/action_2025/edit_ml.t +++ b/t/pause_2025/action_2025/edit_ml.t @@ -9,8 +9,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('admin')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=edit_ml"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/admin/edit_ml"); # note $t->content; } }; diff --git a/t/pause_2025/action_2025/edit_uris.t b/t/pause_2025/action_2025/edit_uris.t index 80c882fdc..be74f58d8 100644 --- a/t/pause_2025/action_2025/edit_uris.t +++ b/t/pause_2025/action_2025/edit_uris.t @@ -19,8 +19,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=edit_uris"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/edit_uris"); # note $t->content; } }; @@ -28,16 +29,17 @@ subtest 'get' => sub { subtest 'post: basic' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); $t->mod_dbh->do("TRUNCATE uris"); # prepare distribution - $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + $t->post_ok("/user/add_uri", $default_for_add_uri, "Content-Type" => "form-data"); my %form = %$default; $form{pause99_edit_uris_3} =~ s/TESTUSER/$user/; - $t->post_ok("$path?ACTION=edit_uris", \%form); + $t->post_ok("/user/edit_uris", \%form); # note $t->content; } }; diff --git a/t/pause_2025/action_2025/email_for_admin.t b/t/pause_2025/action_2025/email_for_admin.t index 4d86b2991..9c6cf5999 100644 --- a/t/pause_2025/action_2025/email_for_admin.t +++ b/t/pause_2025/action_2025/email_for_admin.t @@ -9,8 +9,23 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('admin')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=email_for_admin"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/admin/email_for_admin") + ->text_like("body", qr/TESTADMIN\s+testadmin\@localhost/) + ->text_like("body", qr/TESTUSER\s+testuser\@localhost/); + # note $t->content; + + $t->get_ok("/admin/email_for_admin?OF=YAML"); + my $list_amp = YAML::Syck::Load( $t->content ); + is_deeply( $list_amp, { + TESTADMIN => 'testadmin@localhost', + TESTCNSRD => 'testcnsrd@localhost', + TESTUSER => 'testuser@localhost', + TESTUSER2 => 'testuser2@localhost', + TESTUSER3 => 'testuser3@localhost', + TESTUSER4 => 'testuser4@localhost', + }, "YAML output works" ); # note $t->content; } }; diff --git a/t/pause_2025/action_2025/giveup_comaint.t b/t/pause_2025/action_2025/giveup_comaint.t index c1cb6e4f0..76e13b9c3 100644 --- a/t/pause_2025/action_2025/giveup_comaint.t +++ b/t/pause_2025/action_2025/giveup_comaint.t @@ -18,8 +18,9 @@ subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=giveup_comaint"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/giveup_comaint"); my @modules = map {$_->all_text} $t->dom->find('td.package')->each; if ($user eq 'TESTADMIN') { cmp_bag(\@modules, [qw/ @@ -41,7 +42,8 @@ subtest 'get' => sub { subtest 'normal case (comaint)' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, @@ -49,7 +51,7 @@ subtest 'normal case (comaint)' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=giveup_comaint", \%form); + $t->post_ok("/user/giveup_comaint", \%form); my @modules = map {$_->all_text} $t->dom->find('td.package')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; if ($user eq 'TESTADMIN') { @@ -76,7 +78,8 @@ subtest 'normal case (comaint)' => sub { subtest 'unrelated modules' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, @@ -84,7 +87,7 @@ subtest 'unrelated modules' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=giveup_comaint", \%form); + $t->post_ok("/user/giveup_comaint", \%form); my @modules = map {$_->all_text} $t->dom->find('td.package')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; my @errors = map {$_->all_text} $t->dom->find('.error')->each; diff --git a/t/pause_2025/action_2025/giveup_dist_comaint.t b/t/pause_2025/action_2025/giveup_dist_comaint.t index 7e4e97a91..e6dd81ca1 100644 --- a/t/pause_2025/action_2025/giveup_dist_comaint.t +++ b/t/pause_2025/action_2025/giveup_dist_comaint.t @@ -19,8 +19,9 @@ subtest 'get' => sub { my ($path, $user) = @$test; Test::PAUSE::Web->reset_module_fixture; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=giveup_dist_comaint"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/giveup_dist_comaint"); my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; if ($user eq 'TESTADMIN') { cmp_bag(\@dists, [qw/ @@ -40,7 +41,8 @@ subtest 'get' => sub { subtest 'normal case (comaint)' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, @@ -48,7 +50,7 @@ subtest 'normal case (comaint)' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=giveup_dist_comaint", \%form); + $t->post_ok("/user/giveup_dist_comaint", \%form); my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; if ($user eq 'TESTADMIN') { @@ -75,7 +77,8 @@ subtest 'normal case (comaint)' => sub { subtest 'unrelated dists' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, @@ -83,7 +86,7 @@ subtest 'unrelated dists' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=giveup_dist_comaint", \%form); + $t->post_ok("/user/giveup_dist_comaint", \%form); my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; my @errors = map {$_->all_text} $t->dom->find('.error')->each; diff --git a/t/pause_2025/action_2025/mailpw.t b/t/pause_2025/action_2025/mailpw.t index 5aadcfe7e..16e73ecdf 100644 --- a/t/pause_2025/action_2025/mailpw.t +++ b/t/pause_2025/action_2025/mailpw.t @@ -14,8 +14,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=mailpw"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/public/mailpw"); #note $t->content; } }; @@ -23,10 +24,11 @@ subtest 'get' => sub { subtest 'post: basic' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = %$default; $t->authen_dbh->do("TRUNCATE abrakadabra"); - my $res = $t->post("$path?ACTION=mailpw", \%form); + my $res = $t->post("/public/mailpw", \%form); ok !$res->is_success && $res->code == 403, "Forbidden"; like $res->content => qr/Failed CSRF check/; # note $t->content; @@ -36,10 +38,11 @@ subtest 'post: basic' => sub { subtest 'post_with_token: basic' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = %$default; $t->authen_dbh->do("TRUNCATE abrakadabra"); - $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + $t->post_with_token_ok("/public/mailpw", \%form) ->text_like("p.form_response", qr/A token to change the password/); # note $t->content; } @@ -48,13 +51,14 @@ subtest 'post_with_token: basic' => sub { subtest 'got an email instead of a userid' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_mailpw_1 => 'INV@LID', ); $t->authen_dbh->do("TRUNCATE abrakadabra"); - $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + $t->post_with_token_ok("/public/mailpw", \%form) ->text_is('h2', 'Error') ->text_like('p.error_message', qr/Please supply a userid/s); } @@ -63,13 +67,14 @@ subtest 'got an email instead of a userid' => sub { subtest 'invalid userid' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_mailpw_1 => 'INV#LID', ); $t->authen_dbh->do("TRUNCATE abrakadabra"); - $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + $t->post_with_token_ok("/public/mailpw", \%form) ->text_is('h2', 'Error') ->text_like('p.error_message', qr/A userid of INV#LID is not allowed/s); } @@ -78,13 +83,14 @@ subtest 'invalid userid' => sub { subtest 'cannot find a userid' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_mailpw_1 => 'NOTFOUND', ); $t->authen_dbh->do("TRUNCATE abrakadabra"); - $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + $t->post_with_token_ok("/public/mailpw", \%form) ->text_is('h2', 'Error') ->text_like('p.error_message', qr/Cannot find a userid.+NOTFOUND/s); # note $t->content; @@ -94,13 +100,14 @@ subtest 'cannot find a userid' => sub { subtest 'no secretmail' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, ); $t->authen_dbh->do("TRUNCATE abrakadabra"); $t->authen_db->update('usertable', {secretemail => undef}, {user => "TESTUSER"}); - $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + $t->post_with_token_ok("/public/mailpw", \%form) ->text_like("p.form_response", qr/A token to change the password/); # note $t->content; } @@ -111,12 +118,13 @@ subtest 'no secretmail' => sub { subtest 'requested recently' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = %$default; $t->authen_dbh->do("TRUNCATE abrakadabra"); - $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + $t->post_with_token_ok("/public/mailpw", \%form) ->text_like("p.form_response", qr/A token to change the password/); - $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + $t->post_with_token_ok("/public/mailpw", \%form) ->text_is('h2', 'Error') ->text_like('p.error_message', qr/A token for TESTUSER that allows/s); # note $t->content; @@ -126,7 +134,8 @@ subtest 'requested recently' => sub { subtest 'user without an entry in usertable: has email' => sub { for my $test (Test::PAUSE::Web->tests_for('admin')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_mailpw_1 => "OTHERUSER", @@ -138,7 +147,7 @@ subtest 'user without an entry in usertable: has email' => sub { }, {replace => 1}); $t->authen_db->delete('usertable', {user => 'OTHERUSER'}); ok !@{ $t->authen_db->select('usertable', ['user'], {user => 'OTHERUSER'}) // [] }; - $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + $t->post_with_token_ok("/public/mailpw", \%form) ->text_like("p.form_response", qr/A token to change the password/); # new usertable entry is created @@ -150,7 +159,8 @@ subtest 'user without an entry in usertable: has email' => sub { subtest 'user without an entry in usertable: without email' => sub { for my $test (Test::PAUSE::Web->tests_for('admin')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_mailpw_1 => "OTHERUSER", @@ -162,7 +172,7 @@ subtest 'user without an entry in usertable: without email' => sub { }, {replace => 1}); $t->authen_db->delete('usertable', {user => 'OTHERUSER'}); ok !@{ $t->authen_db->select('usertable', ['user'], {user => 'OTHERUSER'}) // [] }; - $t->post_with_token_ok("$path?ACTION=mailpw", \%form) + $t->post_with_token_ok("/public/mailpw", \%form) ->text_is('h2', 'Error') ->text_like('p.error_message', qr/A userid of OTHERUSER\s+is not known/s); diff --git a/t/pause_2025/action_2025/make_comaint.t b/t/pause_2025/action_2025/make_comaint.t index 0263244b6..1c3350be6 100644 --- a/t/pause_2025/action_2025/make_comaint.t +++ b/t/pause_2025/action_2025/make_comaint.t @@ -18,8 +18,9 @@ Test::PAUSE::Web->reset_module_fixture; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=make_comaint"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/make_comaint"); my @modules = map {$_->all_text} $t->dom->find('td.package')->each; if ($user eq 'TESTADMIN') { cmp_set(\@modules, [qw/ @@ -41,7 +42,8 @@ subtest 'get' => sub { subtest 'normal case' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my @packages; if ($user eq 'TESTADMIN') { @@ -58,7 +60,7 @@ subtest 'normal case' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=make_comaint", \%form); + $t->post_ok("/user/make_comaint", \%form); my @modules = map {$_->all_text} $t->dom->find('td.package')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; if ($user eq 'TESTADMIN') { @@ -83,12 +85,12 @@ subtest 'normal case' => sub { note $t->content; } }; -done_testing;exit; subtest 'unknown user' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my @packages; if ($user eq 'TESTADMIN') { @@ -105,7 +107,7 @@ subtest 'unknown user' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=make_comaint", \%form); + $t->post_ok("/user/make_comaint", \%form); my @modules = map {$_->all_text} $t->dom->find('td.package')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; my @errors = map {$_->all_text} $t->dom->find('.error')->each; @@ -133,7 +135,8 @@ subtest 'unknown user' => sub { subtest 'unrelated modules' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, @@ -142,7 +145,7 @@ subtest 'unrelated modules' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=make_comaint", \%form); + $t->post_ok("/user/make_comaint", \%form); my @modules = map {$_->all_text} $t->dom->find('td.package')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; my @errors = map {$_->all_text} $t->dom->find('.error')->each; diff --git a/t/pause_2025/action_2025/make_dist_comaint.t b/t/pause_2025/action_2025/make_dist_comaint.t index 2bd1cc9d3..f9295e7b7 100644 --- a/t/pause_2025/action_2025/make_dist_comaint.t +++ b/t/pause_2025/action_2025/make_dist_comaint.t @@ -18,8 +18,9 @@ Test::PAUSE::Web->reset_module_fixture; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=make_dist_comaint"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/make_dist_comaint"); my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; if ($user eq 'TESTADMIN') { cmp_set(\@dists, [qw/ @@ -40,7 +41,8 @@ subtest 'get' => sub { subtest 'normal case' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my @dists; if ($user eq 'TESTADMIN') { @@ -57,7 +59,7 @@ subtest 'normal case' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=make_dist_comaint", \%form); + $t->post_ok("/user/make_dist_comaint", \%form); @dists = map {$_->all_text} $t->dom->find('td.dist')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; if ($user eq 'TESTADMIN') { @@ -87,7 +89,8 @@ subtest 'normal case' => sub { subtest 'unknown user' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my @dists; if ($user eq 'TESTADMIN') { @@ -104,7 +107,7 @@ subtest 'unknown user' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=make_dist_comaint", \%form); + $t->post_ok("/user/make_dist_comaint", \%form); @dists = map {$_->all_text} $t->dom->find('td.dist')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; my @errors = map {$_->all_text} $t->dom->find('.error')->each; @@ -130,7 +133,8 @@ subtest 'unknown user' => sub { subtest 'unrelated dists' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, @@ -139,7 +143,7 @@ subtest 'unrelated dists' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=make_dist_comaint", \%form); + $t->post_ok("/user/make_dist_comaint", \%form); my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; my @errors = map {$_->all_text} $t->dom->find('.error')->each; diff --git a/t/pause_2025/action_2025/manage_id_requests.t b/t/pause_2025/action_2025/manage_id_requests.t index 9113a3a83..0b9a69e8f 100644 --- a/t/pause_2025/action_2025/manage_id_requests.t +++ b/t/pause_2025/action_2025/manage_id_requests.t @@ -9,8 +9,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('admin')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=manage_id_requests"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/admin/manage_id_requests"); # note $t->content; } }; diff --git a/t/pause_2025/action_2025/move_dist_primary.t b/t/pause_2025/action_2025/move_dist_primary.t index bcbd2132f..f38564aee 100644 --- a/t/pause_2025/action_2025/move_dist_primary.t +++ b/t/pause_2025/action_2025/move_dist_primary.t @@ -18,8 +18,9 @@ Test::PAUSE::Web->reset_module_fixture; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=move_dist_primary"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/move_dist_primary"); my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; if ($user eq 'TESTADMIN') { cmp_bag(\@dists, [qw/ @@ -39,7 +40,8 @@ subtest 'get' => sub { subtest 'normal case' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my @dists; if ($user eq 'TESTADMIN') { @@ -56,7 +58,7 @@ subtest 'normal case' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=move_dist_primary", \%form); + $t->post_ok("/user/move_dist_primary", \%form); @dists = map {$_->all_text} $t->dom->find('td.dist')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; if ($user eq 'TESTADMIN') { @@ -83,7 +85,8 @@ subtest 'normal case' => sub { subtest 'unknown user' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my @dists; if ($user eq 'TESTADMIN') { @@ -100,7 +103,7 @@ subtest 'unknown user' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=move_dist_primary", \%form); + $t->post_ok("/user/move_dist_primary", \%form); my @new_dists = map {$_->all_text} $t->dom->find('td.dist')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; my @errors = map {$_->all_text} $t->dom->find('.error')->each; @@ -126,7 +129,8 @@ subtest 'unknown user' => sub { subtest 'unrelated dists' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, @@ -135,7 +139,7 @@ subtest 'unrelated dists' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=move_dist_primary", \%form); + $t->post_ok("/user/move_dist_primary", \%form); my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; my @errors = map {$_->all_text} $t->dom->find('.error')->each; diff --git a/t/pause_2025/action_2025/move_primary.t b/t/pause_2025/action_2025/move_primary.t index e9a739229..2512a73c7 100644 --- a/t/pause_2025/action_2025/move_primary.t +++ b/t/pause_2025/action_2025/move_primary.t @@ -19,8 +19,9 @@ subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=move_primary"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/move_primary"); my @modules = map {$_->all_text} $t->dom->find('td.package')->each; if ($user eq 'TESTADMIN') { cmp_bag(\@modules, [qw/ @@ -42,7 +43,8 @@ subtest 'get' => sub { subtest 'normal case' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my @packages; if ($user eq 'TESTADMIN') { @@ -59,7 +61,7 @@ subtest 'normal case' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=move_primary", \%form); + $t->post_ok("/user/move_primary", \%form); my @modules = map {$_->all_text} $t->dom->find('td.package')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; if ($user eq 'TESTADMIN') { @@ -86,7 +88,8 @@ subtest 'normal case' => sub { subtest 'unknown user' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my @packages; if ($user eq 'TESTADMIN') { @@ -103,7 +106,7 @@ subtest 'unknown user' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=move_primary", \%form); + $t->post_ok("/user/move_primary", \%form); my @modules = map {$_->all_text} $t->dom->find('td.package')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; my @errors = map {$_->all_text} $t->dom->find('.error')->each; @@ -131,7 +134,8 @@ subtest 'unknown user' => sub { subtest 'unrelated modules' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, @@ -140,7 +144,7 @@ subtest 'unrelated modules' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=move_primary", \%form); + $t->post_ok("/user/move_primary", \%form); my @modules = map {$_->all_text} $t->dom->find('td.package')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; my @errors = map {$_->all_text} $t->dom->find('.error')->each; diff --git a/t/pause_2025/action_2025/pause_04about.t b/t/pause_2025/action_2025/pause_04about.t index 05773616f..c13621fed 100644 --- a/t/pause_2025/action_2025/pause_04about.t +++ b/t/pause_2025/action_2025/pause_04about.t @@ -9,8 +9,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=pause_04about"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/public/pause_04about"); # note $t->content; } }; diff --git a/t/pause_2025/action_2025/pause_04imprint.t b/t/pause_2025/action_2025/pause_04imprint.t index 780605e78..c2f01cdd8 100644 --- a/t/pause_2025/action_2025/pause_04imprint.t +++ b/t/pause_2025/action_2025/pause_04imprint.t @@ -9,8 +9,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=pause_04imprint"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/public/pause_04imprint"); # note $t->content; } }; diff --git a/t/pause_2025/action_2025/pause_05news.t b/t/pause_2025/action_2025/pause_05news.t index e033387c2..48a6aa23a 100644 --- a/t/pause_2025/action_2025/pause_05news.t +++ b/t/pause_2025/action_2025/pause_05news.t @@ -9,8 +9,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=pause_05news"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/public/pause_05news"); # note $t->content; } }; diff --git a/t/pause_2025/action_2025/pause_06history.t b/t/pause_2025/action_2025/pause_06history.t index 79aed17ab..f71e80b1d 100644 --- a/t/pause_2025/action_2025/pause_06history.t +++ b/t/pause_2025/action_2025/pause_06history.t @@ -9,8 +9,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=pause_06history"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/public/pause_06history"); # note $t->content; } }; diff --git a/t/pause_2025/action_2025/pause_namingmodules.t b/t/pause_2025/action_2025/pause_namingmodules.t index 443064d5d..62de8f0d4 100644 --- a/t/pause_2025/action_2025/pause_namingmodules.t +++ b/t/pause_2025/action_2025/pause_namingmodules.t @@ -9,8 +9,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=pause_namingmodules"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/public/pause_namingmodules"); # note $t->content; } }; diff --git a/t/pause_2025/action_2025/pause_operating_model.t b/t/pause_2025/action_2025/pause_operating_model.t index c502086ba..8ce328fe8 100644 --- a/t/pause_2025/action_2025/pause_operating_model.t +++ b/t/pause_2025/action_2025/pause_operating_model.t @@ -9,8 +9,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=pause_operating_model"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/public/pause_operating_model"); # note $t->content; } }; diff --git a/t/pause_2025/action_2025/pause_privacy_policy.t b/t/pause_2025/action_2025/pause_privacy_policy.t index d33518728..5f017f975 100644 --- a/t/pause_2025/action_2025/pause_privacy_policy.t +++ b/t/pause_2025/action_2025/pause_privacy_policy.t @@ -9,8 +9,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=pause_privacy_policy"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/public/pause_privacy_policy"); # note $t->content; } }; diff --git a/t/pause_2025/action_2025/peek_dist_perms.t b/t/pause_2025/action_2025/peek_dist_perms.t index 52532ea24..74ab30552 100644 --- a/t/pause_2025/action_2025/peek_dist_perms.t +++ b/t/pause_2025/action_2025/peek_dist_perms.t @@ -19,8 +19,9 @@ Test::PAUSE::Web->reset_module_fixture; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=peek_dist_perms"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/peek_dist_perms"); # note $t->content; } }; @@ -30,13 +31,14 @@ subtest 'search by author' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_peek_dist_perms_query => $user, ); - $t->$method("$path?ACTION=peek_dist_perms", \%form); + $t->$method("/user/peek_dist_perms", \%form); my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; if ($user eq 'TESTADMIN') { cmp_bag(\@dists, [qw/ @@ -55,7 +57,7 @@ subtest 'search by author' => sub { } # note $t->content; - $t->$method("$path?ACTION=peek_dist_perms&OF=YAML", \%form); + $t->$method("/user/peek_dist_perms?OF=YAML", \%form); my $list = YAML::Syck::Load( $t->content ); if ($user eq 'TESTADMIN') { eq_or_diff( $list => [ @@ -104,21 +106,22 @@ subtest 'search by dist (exact)' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_peek_dist_perms_query => 'Module-User', pause99_peek_dist_perms_by => 'de', ); - $t->$method("$path?ACTION=peek_dist_perms", \%form); + $t->$method("/user/peek_dist_perms", \%form); my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; cmp_set(\@dists, [qw/ Module-User /]) or note explain \@dists; # note $t->content; - $t->$method("$path?ACTION=peek_dist_perms&OF=YAML", \%form); + $t->$method("/user/peek_dist_perms?OF=YAML", \%form); my $list = YAML::Syck::Load( $t->content ); eq_or_diff( $list => [ { @@ -136,14 +139,15 @@ subtest 'search by module (sql-like)' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_peek_dist_perms_query => 'Module-User%', pause99_peek_dist_perms_by => 'dl', ); - $t->$method("$path?ACTION=peek_dist_perms", \%form); + $t->$method("/user/peek_dist_perms", \%form); my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; cmp_set(\@dists, [qw/ Module-User @@ -151,7 +155,7 @@ subtest 'search by module (sql-like)' => sub { /]) or note explain \@dists; # note $t->content; - $t->$method("$path?ACTION=peek_dist_perms&OF=YAML", \%form); + $t->$method("/user/peek_dist_perms?OF=YAML", \%form); my $list = YAML::Syck::Load( $t->content ); eq_or_diff( $list => [ { diff --git a/t/pause_2025/action_2025/peek_perms.t b/t/pause_2025/action_2025/peek_perms.t index 74f816693..f25f1c6b9 100644 --- a/t/pause_2025/action_2025/peek_perms.t +++ b/t/pause_2025/action_2025/peek_perms.t @@ -19,8 +19,9 @@ Test::PAUSE::Web->reset_module_fixture; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=peek_perms"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/peek_perms"); # note $t->content; } }; @@ -30,13 +31,14 @@ subtest 'search by author' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_peek_perms_query => $user, ); - $t->$method("$path?ACTION=peek_perms", \%form); + $t->$method("/user/peek_perms", \%form); my @modules = map {$_->all_text} $t->dom->find('td.module')->each; my @types = map {$_->all_text} $t->dom->find('td.type')->each; if ($user eq 'TESTADMIN') { @@ -61,7 +63,7 @@ subtest 'search by author' => sub { } # note $t->content; - $t->$method("$path?ACTION=peek_perms&OF=YAML", \%form); + $t->$method("/user/peek_perms?OF=YAML", \%form); my $list = YAML::Syck::Load( $t->content ); if ($user eq 'TESTADMIN') { eq_or_diff( $list => [ @@ -140,14 +142,15 @@ subtest 'search by module (exact)' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_peek_perms_query => 'Module::User::Foo', pause99_peek_perms_by => 'me', ); - $t->$method("$path?ACTION=peek_perms", \%form); + $t->$method("/user/peek_perms", \%form); my @modules = map {$_->all_text} $t->dom->find('td.module')->each; my @types = map {$_->all_text} $t->dom->find('td.type')->each; cmp_set(\@modules, [qw/ @@ -156,7 +159,7 @@ subtest 'search by module (exact)' => sub { ok grep(/co-maint/, @types), 'Has co-maint'; # note $t->content; - $t->$method("$path?ACTION=peek_perms&OF=YAML", \%form); + $t->$method("/user/peek_perms?OF=YAML", \%form); my $list = YAML::Syck::Load( $t->content ); eq_or_diff( $list => [ { @@ -181,14 +184,15 @@ subtest 'search by module (sql-like)' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_peek_perms_query => 'Module::User::%', pause99_peek_perms_by => 'ml', ); - $t->$method("$path?ACTION=peek_perms", \%form); + $t->$method("/user/peek_perms", \%form); my @modules = map {$_->all_text} $t->dom->find('td.module')->each; my @types = map {$_->all_text} $t->dom->find('td.type')->each; cmp_set(\@modules, [qw/ @@ -199,7 +203,7 @@ subtest 'search by module (sql-like)' => sub { ok grep(/co-maint/, @types), 'Has co-maint'; # note $t->content; - $t->$method("$path?ACTION=peek_perms&OF=YAML", \%form); + $t->$method("/user/peek_perms?OF=YAML", \%form); my $list = YAML::Syck::Load( $t->content ); eq_or_diff( $list => [ { diff --git a/t/pause_2025/action_2025/reindex.t b/t/pause_2025/action_2025/reindex.t index 3d0df8430..21b1e4999 100644 --- a/t/pause_2025/action_2025/reindex.t +++ b/t/pause_2025/action_2025/reindex.t @@ -19,8 +19,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=reindex"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/reindex"); # note $t->content; } }; @@ -29,17 +30,18 @@ subtest 'post: basic' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); $t->mod_dbh->do("TRUNCATE uris"); # prepare distribution - $t->post_ok("$path?ACTION=add_uri", $default_for_add_uri, "Content-Type" => "form-data"); + $t->post_ok("/user/add_uri", $default_for_add_uri, "Content-Type" => "form-data"); $t->copy_to_authors_dir($user, scalar Test::PAUSE::Web->file_to_upload); my %form = %$default; - $t->post_ok("$path?ACTION=reindex", \%form); + $t->post_ok("/user/reindex", \%form); # note $t->content; } }; diff --git a/t/pause_2025/action_2025/remove_comaint.t b/t/pause_2025/action_2025/remove_comaint.t index 752dcba37..4d5ed74cb 100644 --- a/t/pause_2025/action_2025/remove_comaint.t +++ b/t/pause_2025/action_2025/remove_comaint.t @@ -17,8 +17,9 @@ Test::PAUSE::Web->reset_module_fixture; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=remove_comaint"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/remove_comaint"); my @modules = map {$_->all_text} $t->dom->find('td.package')->each; if ($user eq 'TESTADMIN') { cmp_set(\@modules, [qw/ @@ -39,7 +40,8 @@ subtest 'get' => sub { subtest 'normal case' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my @tuples; if ($user eq 'TESTADMIN') { @@ -60,7 +62,7 @@ subtest 'normal case' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=remove_comaint", \%form); + $t->post_ok("/user/remove_comaint", \%form); my @modules = map {$_->all_text} $t->dom->find('td.package')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; if ($user eq 'TESTADMIN') { @@ -86,7 +88,8 @@ subtest 'normal case' => sub { subtest 'broken tuple (not the owner)' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, @@ -94,7 +97,7 @@ subtest 'broken tuple (not the owner)' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=remove_comaint", \%form); + $t->post_ok("/user/remove_comaint", \%form); my @modules = map {$_->all_text} $t->dom->find('td.package')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; my @errors = map {$_->all_text} $t->dom->find('.error')->each; @@ -121,7 +124,8 @@ subtest 'broken tuple (not the owner)' => sub { subtest 'broken tuple (not the comaint)' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my @tuples; if ($user eq 'TESTADMIN') { @@ -142,7 +146,7 @@ subtest 'broken tuple (not the comaint)' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=remove_comaint", \%form); + $t->post_ok("/user/remove_comaint", \%form); my @modules = map {$_->all_text} $t->dom->find('td.package')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; my @errors = map {$_->all_text} $t->dom->find('.error')->each; diff --git a/t/pause_2025/action_2025/remove_dist_comaint.t b/t/pause_2025/action_2025/remove_dist_comaint.t index db476fde3..4cc161f71 100644 --- a/t/pause_2025/action_2025/remove_dist_comaint.t +++ b/t/pause_2025/action_2025/remove_dist_comaint.t @@ -17,8 +17,9 @@ Test::PAUSE::Web->reset_module_fixture; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=remove_dist_comaint"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/remove_dist_comaint"); my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; if ($user eq 'TESTADMIN') { cmp_set(\@dists, [qw/ @@ -37,7 +38,8 @@ subtest 'get' => sub { subtest 'normal case' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my @tuples; if ($user eq 'TESTADMIN') { @@ -57,7 +59,7 @@ subtest 'normal case' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=remove_dist_comaint", \%form); + $t->post_ok("/user/remove_dist_comaint", \%form); my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; if ($user eq 'TESTADMIN') { @@ -84,7 +86,8 @@ subtest 'normal case' => sub { subtest 'broken tuple (not an owner)' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, @@ -92,7 +95,7 @@ subtest 'broken tuple (not an owner)' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=remove_dist_comaint", \%form); + $t->post_ok("/user/remove_dist_comaint", \%form); my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; my @errors = map {$_->all_text} $t->dom->find('.error')->each; @@ -117,7 +120,8 @@ subtest 'broken tuple (not an owner)' => sub { subtest 'broken tuple (not a comaint)' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my @tuples; if ($user eq 'TESTADMIN') { @@ -138,7 +142,7 @@ subtest 'broken tuple (not a comaint)' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=remove_dist_comaint", \%form); + $t->post_ok("/user/remove_dist_comaint", \%form); my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; my @errors = map {$_->all_text} $t->dom->find('.error')->each; diff --git a/t/pause_2025/action_2025/remove_dist_primary.t b/t/pause_2025/action_2025/remove_dist_primary.t index 06d7c3342..ef8bd6866 100644 --- a/t/pause_2025/action_2025/remove_dist_primary.t +++ b/t/pause_2025/action_2025/remove_dist_primary.t @@ -18,8 +18,9 @@ subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=remove_dist_primary"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/remove_dist_primary"); my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; if ($user eq 'TESTADMIN') { cmp_bag(\@dists, [qw/ @@ -39,7 +40,8 @@ subtest 'get' => sub { subtest 'normal case' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my @dists; if ($user eq 'TESTADMIN') { @@ -55,7 +57,7 @@ subtest 'normal case' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=remove_dist_primary", \%form); + $t->post_ok("/user/remove_dist_primary", \%form); @dists = map {$_->all_text} $t->dom->find('td.dist')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; if ($user eq 'TESTADMIN') { @@ -67,7 +69,7 @@ subtest 'normal case' => sub { ]); # really transferred to ADOPTME? - $t->get_ok("$path?ACTION=peek_dist_perms", { + $t->get_ok("/user/peek_dist_perms", { pause99_peek_dist_perms_query => "ADOPTME", pause99_peek_dist_perms_by => "a", pause99_peek_dist_perms_sub => 1, @@ -85,7 +87,7 @@ subtest 'normal case' => sub { ]); # really transferred to ADOPTME? - $t->get_ok("$path?ACTION=peek_dist_perms", { + $t->get_ok("/user/peek_dist_perms", { pause99_peek_dist_perms_query => "ADOPTME", pause99_peek_dist_perms_by => "a", pause99_peek_dist_perms_sub => 1, @@ -100,7 +102,8 @@ subtest 'normal case' => sub { subtest 'unrelated dists' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, @@ -108,7 +111,7 @@ subtest 'unrelated dists' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=remove_dist_primary", \%form); + $t->post_ok("/user/remove_dist_primary", \%form); my @dists = map {$_->all_text} $t->dom->find('td.dist')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; my @warnings = map {$_->all_text} $t->dom->find('.warning')->each; diff --git a/t/pause_2025/action_2025/remove_primary.t b/t/pause_2025/action_2025/remove_primary.t index e6f82d58d..32b28a2d6 100644 --- a/t/pause_2025/action_2025/remove_primary.t +++ b/t/pause_2025/action_2025/remove_primary.t @@ -18,8 +18,9 @@ subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=remove_primary"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/remove_primary"); my @modules = map {$_->all_text} $t->dom->find('td.package')->each; if ($user eq 'TESTADMIN') { cmp_bag(\@modules, [qw/ @@ -41,7 +42,8 @@ subtest 'get' => sub { subtest 'normal case' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my @packages; if ($user eq 'TESTADMIN') { @@ -57,7 +59,7 @@ subtest 'normal case' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=remove_primary", \%form); + $t->post_ok("/user/remove_primary", \%form); my @modules = map {$_->all_text} $t->dom->find('td.package')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; if ($user eq 'TESTADMIN') { @@ -69,7 +71,7 @@ subtest 'normal case' => sub { ]); # really transferred to ADOPTME? - $t->get_ok("$path?ACTION=peek_perms", { + $t->get_ok("/user/peek_perms", { pause99_peek_perms_query => "ADOPTME", pause99_peek_perms_by => "a", pause99_peek_perms_sub => 1, @@ -87,7 +89,7 @@ subtest 'normal case' => sub { ]); # really transferred to ADOPTME? - $t->get_ok("$path?ACTION=peek_perms", { + $t->get_ok("/user/peek_perms", { pause99_peek_perms_query => "ADOPTME", pause99_peek_perms_by => "a", pause99_peek_perms_sub => 1, @@ -102,7 +104,8 @@ subtest 'normal case' => sub { subtest 'unrelated modules' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, @@ -110,7 +113,7 @@ subtest 'unrelated modules' => sub { ); Test::PAUSE::Web->reset_module_fixture; - $t->post_ok("$path?ACTION=remove_primary", \%form); + $t->post_ok("/user/remove_primary", \%form); my @modules = map {$_->all_text} $t->dom->find('td.package')->each; my @results = map {$_->all_text} $t->dom->find('.result')->each; my @warnings = map {$_->all_text} $t->dom->find('.warning')->each; diff --git a/t/pause_2025/action_2025/request_id.t b/t/pause_2025/action_2025/request_id.t index 8936d08bb..f1257556e 100644 --- a/t/pause_2025/action_2025/request_id.t +++ b/t/pause_2025/action_2025/request_id.t @@ -18,8 +18,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=request_id"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/public/request_id"); # note $t->content; } }; @@ -27,9 +28,10 @@ subtest 'get' => sub { subtest 'post: basic' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = %$default; - $t->post_ok("$path?ACTION=request_id", \%form) + $t->post_ok("/public/request_id", \%form) ->text_like("pre.email_sent", qr/Subject: PAUSE ID request \(NEWUSER/); is $t->deliveries => 2, "two deliveries (one for admin, one for requester)"; # note $t->content; @@ -39,12 +41,13 @@ subtest 'post: basic' => sub { subtest 'post: thank you, bot' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, url => 'http://host/path', ); - $t->post_ok("$path?ACTION=request_id", \%form); + $t->post_ok("/public/request_id", \%form); is $t->content => "Thank you!"; ok !$t->deliveries, "no deliveries"; # note $t->content; @@ -54,12 +57,13 @@ subtest 'post: thank you, bot' => sub { subtest 'post: no space in full name' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_request_id_fullname => 'FULLNAME', ); - $t->post_ok("$path?ACTION=request_id", \%form) + $t->post_ok("/public/request_id", \%form) ->text_is("h3", "Error processing form") ->text_like("ul.errors li", qr/Name does not look like a full civil name/); ok !$t->deliveries, "no deliveries"; @@ -70,12 +74,13 @@ subtest 'post: no space in full name' => sub { subtest 'post: no full name' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_request_id_fullname => '', ); - $t->post_ok("$path?ACTION=request_id", \%form) + $t->post_ok("/public/request_id", \%form) ->text_is("h3", "Error processing form") ->text_like("ul.errors li", qr/You must supply a name/); ok !$t->deliveries, "no deliveries"; @@ -86,12 +91,13 @@ subtest 'post: no full name' => sub { subtest 'post: no email' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_request_id_email => '', ); - $t->post_ok("$path?ACTION=request_id", \%form) + $t->post_ok("/public/request_id", \%form) ->text_is("h3", "Error processing form") ->text_like("ul.errors li", qr/You must supply an email address/); ok !$t->deliveries, "no deliveries"; @@ -102,12 +108,13 @@ subtest 'post: no email' => sub { subtest 'post: invalid email' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_request_id_email => 'no email', ); - $t->post_ok("$path?ACTION=request_id", \%form) + $t->post_ok("/public/request_id", \%form) ->text_is("h3", "Error processing form") ->text_like("ul.errors li", qr/Your email address doesn't look like valid email address./); ok !$t->deliveries, "no deliveries"; @@ -118,12 +125,13 @@ subtest 'post: invalid email' => sub { subtest 'post: rational is too short' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_request_id_rationale => 'rationale', ); - $t->post_ok("$path?ACTION=request_id", \%form) + $t->post_ok("/public/request_id", \%form) ->text_is("h3", "Error processing form") ->text_like("ul.errors li", qr/this looks a\s+bit too short/); ok !$t->deliveries, "no deliveries"; @@ -135,12 +143,13 @@ subtest 'post: rational is too short' => sub { subtest 'post: rational has html links' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_request_id_rationale => '', ); - $t->post_ok("$path?ACTION=request_id", \%form) + $t->post_ok("/public/request_id", \%form) ->text_is("h3", "Error processing form") ->text_like("ul.errors li", qr/Please do not use HTML links/); ok !$t->deliveries, "no deliveries"; @@ -151,7 +160,8 @@ subtest 'post: rational has html links' => sub { subtest 'post: multiple links' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_request_id_rationale => <<'SPAM', @@ -159,7 +169,7 @@ http://spam/path http://spam/path SPAM ); - $t->post_ok("$path?ACTION=request_id", \%form) + $t->post_ok("/public/request_id", \%form) ->text_is("h3", "Error processing form") ->text_like("ul.errors li", qr/Please do not include more than one URL/); ok !$t->deliveries, "no deliveries"; @@ -170,12 +180,13 @@ SPAM subtest 'post: no rationale' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_request_id_rationale => '', ); - $t->post_ok("$path?ACTION=request_id", \%form) + $t->post_ok("/public/request_id", \%form) ->text_is("h3", "Error processing form") ->text_like("ul.errors li", qr/You must supply a short description/); ok !$t->deliveries, "no deliveries"; @@ -186,12 +197,13 @@ subtest 'post: no rationale' => sub { subtest 'post: userid is taken' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_request_id_userid => 'TESTUSER', ); - $t->post_ok("$path?ACTION=request_id", \%form) + $t->post_ok("/public/request_id", \%form) ->text_is("h3", "Error processing form") ->text_like("ul.errors li", qr/The userid TESTUSER is already taken/); ok !$t->deliveries, "no deliveries"; @@ -202,12 +214,13 @@ subtest 'post: userid is taken' => sub { subtest 'post: invalid userid' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_request_id_userid => 'INV#LID', ); - $t->post_ok("$path?ACTION=request_id", \%form) + $t->post_ok("/public/request_id", \%form) ->text_is("h3", "Error processing form") ->text_like("ul.errors li", qr/The userid INV#LID does not match/); ok !$t->deliveries, "no deliveries"; @@ -218,12 +231,13 @@ subtest 'post: invalid userid' => sub { subtest 'post: no userid' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_request_id_userid => '', ); - $t->post_ok("$path?ACTION=request_id", \%form) + $t->post_ok("/public/request_id", \%form) ->text_is("h3", "Error processing form") ->text_like("ul.errors li", qr/You must supply a desired user-ID/); ok !$t->deliveries, "no deliveries"; @@ -234,7 +248,8 @@ subtest 'post: no userid' => sub { subtest 'post: lots of .info' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_request_id_rationale => <<'SPAM', @@ -245,7 +260,7 @@ ttp://spam.info ttp://spam.info SPAM ); - $t->post_ok("$path?ACTION=request_id", \%form) + $t->post_ok("/public/request_id", \%form) ->text_is("h2", "Error") ->text_like("p.error_message", qr/rationale looks like spam/); ok !$t->deliveries, "no deliveries"; @@ -256,13 +271,14 @@ SPAM subtest 'post: interesting .cn homepage' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = ( %$default, pause99_request_id_homepage => 'http://some.cn/index.htm', pause99_request_id_rationale => 'interesting site', ); - $t->post_ok("$path?ACTION=request_id", \%form) + $t->post_ok("/public/request_id", \%form) ->text_is("h2", "Error") ->text_like("p.error_message", qr/rationale looks like spam/); ok !$t->deliveries, "no deliveries"; diff --git a/t/pause_2025/action_2025/reset_version.t b/t/pause_2025/action_2025/reset_version.t index 45c37dc89..60f96653e 100644 --- a/t/pause_2025/action_2025/reset_version.t +++ b/t/pause_2025/action_2025/reset_version.t @@ -14,8 +14,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=reset_version"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/reset_version"); # note $t->content; } }; @@ -23,7 +24,8 @@ subtest 'get' => sub { subtest 'post: basic' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); $t->mod_dbh->do("TRUNCATE packages"); $t->mod_db->insert('packages', { @@ -40,7 +42,7 @@ subtest 'post: basic' => sub { }); my %form = %$default; - $t->post_ok("$path?ACTION=reset_version", \%form); + $t->post_ok("/user/reset_version", \%form); # note $t->content; } }; diff --git a/t/pause_2025/action_2025/select_ml_action.t b/t/pause_2025/action_2025/select_ml_action.t index 75bda972b..5440333dd 100644 --- a/t/pause_2025/action_2025/select_ml_action.t +++ b/t/pause_2025/action_2025/select_ml_action.t @@ -22,8 +22,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('admin')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=select_ml_action"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/mlrepr/select_ml_action"); # note $t->content; } }; @@ -31,9 +32,10 @@ subtest 'get' => sub { subtest 'post: basic' => sub { for my $test (Test::PAUSE::Web->tests_for('admin')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); - $t->post_ok("$path?ACTION=add_user", $mailing_list); + $t->post_ok("/admin/add_user", $mailing_list); $t->mod_db->insert("list2user", { maillistid => "MAILLIST", @@ -41,8 +43,8 @@ subtest 'post: basic' => sub { }, {ignore => 1}); my %form = %$default; - $t->post_ok("$path?ACTION=select_ml_action", \%form); - # note $t->content; + $t->post_ok("/mlrepr/select_ml_action", \%form); + note $t->content; } }; diff --git a/t/pause_2025/action_2025/select_user.t b/t/pause_2025/action_2025/select_user.t index 3d6ac280e..5ed844b67 100644 --- a/t/pause_2025/action_2025/select_user.t +++ b/t/pause_2025/action_2025/select_user.t @@ -9,8 +9,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('admin')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=select_user"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/admin/select_user"); # note $t->content; } }; diff --git a/t/pause_2025/action_2025/share_perms.t b/t/pause_2025/action_2025/share_perms.t index 76c4be7bf..1af2a33b3 100644 --- a/t/pause_2025/action_2025/share_perms.t +++ b/t/pause_2025/action_2025/share_perms.t @@ -9,8 +9,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=share_perms"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/share_perms"); # note $t->content; } }; diff --git a/t/pause_2025/action_2025/show_files.t b/t/pause_2025/action_2025/show_files.t index 9c6b61797..8960bc84b 100644 --- a/t/pause_2025/action_2025/show_files.t +++ b/t/pause_2025/action_2025/show_files.t @@ -9,8 +9,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=show_files"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/show_files"); # note $t->content; } }; diff --git a/t/pause_2025/action_2025/show_ml_repr.t b/t/pause_2025/action_2025/show_ml_repr.t index 2fc8bce41..b9ced8642 100644 --- a/t/pause_2025/action_2025/show_ml_repr.t +++ b/t/pause_2025/action_2025/show_ml_repr.t @@ -9,8 +9,9 @@ Test::PAUSE::Web->setup; subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('admin')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path?ACTION=show_ml_repr"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/mlrepr/show_ml_repr"); # note $t->content; } }; diff --git a/t/pause_2025/action_2025/tail_logfile.t b/t/pause_2025/action_2025/tail_logfile.t index 49bb91888..f49f812ca 100644 --- a/t/pause_2025/action_2025/tail_logfile.t +++ b/t/pause_2025/action_2025/tail_logfile.t @@ -23,8 +23,9 @@ LOG subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("/pause/authenquery?ACTION=tail_logfile"); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/tail_logfile"); # note $t->content; } }; @@ -32,10 +33,11 @@ subtest 'get' => sub { subtest 'post: basic' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); my %form = %$default; - $t->post_ok("$path?ACTION=tail_logfile", \%form); + $t->post_ok("/user/tail_logfile", \%form); # note $t->content; } }; diff --git a/t/pause_2025/action_2025/who_admin.t b/t/pause_2025/action_2025/who_admin.t index f8a41cb07..b7918d74c 100644 --- a/t/pause_2025/action_2025/who_admin.t +++ b/t/pause_2025/action_2025/who_admin.t @@ -23,21 +23,15 @@ subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); - $t->get_ok("$path?ACTION=who_admin") + $t->get_ok("/public/who_admin") ->text_like('body', qr/Registered admins:\s+BAR, FOO/); - $t->get_ok("$path?ACTION=who_admin&OF=YAML"); + $t->get_ok("/public/who_admin?OF=YAML"); my $list_amp = YAML::Syck::Load( $t->content ); is_deeply( $list_amp, [qw/BAR FOO TESTADMIN/], "YAML output works" ); - - SKIP: { - skip "; is not supported anymore", 1; - $t->get_ok("$path?ACTION=who_admin;OF=YAML"); - my $list_sem = YAML::Syck::Load( $t->content ); - is_deeply( $list_sem, [qw/BAR FOO TESTADMIN/], "YAML output works" ); - } } }; diff --git a/t/pause_2025/action_2025/who_pumpkin.t b/t/pause_2025/action_2025/who_pumpkin.t index 4e60d2bc5..05f5d576a 100644 --- a/t/pause_2025/action_2025/who_pumpkin.t +++ b/t/pause_2025/action_2025/who_pumpkin.t @@ -23,21 +23,15 @@ subtest 'get' => sub { for my $test (Test::PAUSE::Web->tests_for('public')) { my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); - $t->get_ok("$path?ACTION=who_pumpkin") + $t->get_ok("/public/who_pumpkin") ->text_like("body", qr/Registered pumpkins:\s+BAR, FOO/); - $t->get_ok("$path?ACTION=who_pumpkin&OF=YAML"); + $t->get_ok("/public/who_pumpkin?OF=YAML"); my $list_amp = YAML::Syck::Load( $t->content ); is_deeply( $list_amp, [qw/BAR FOO/], "YAML output works" ); - - SKIP: { - skip "; is not supported anymore", 1; - $t->get_ok("$path?ACTION=who_pumpkin;OF=YAML"); - my $list_sem = YAML::Syck::Load( $t->content ); - is_deeply( $list_sem, [qw/BAR FOO/], "YAML output works" ); - } } }; diff --git a/t/pause_2025/auth.t b/t/pause_2025/auth.t index 78f0fd6a9..96b9c16b3 100644 --- a/t/pause_2025/auth.t +++ b/t/pause_2025/auth.t @@ -7,56 +7,115 @@ use utf8; Test::PAUSE::Web->setup; -subtest 'basic' => sub { - my $test = Test::PAUSE::Web->tests_for('user'); - my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - my $res = $t->get("$path");; - ok $res->is_success; -}; +subtest 'for 2017 app' => sub { + subtest 'basic' => sub { + my $test = Test::PAUSE::Web->tests_for('user'); + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my $res = $t->get("$path"); + ok $res->is_success; + }; -subtest 'lower case' => sub { - my $test = Test::PAUSE::Web->tests_for('user'); - my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => lc $user); - my $res = $t->get("$path");; - ok $res->is_success; -}; + subtest 'lower case' => sub { + my $test = Test::PAUSE::Web->tests_for('user'); + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => lc $user); + my $res = $t->get("$path"); + ok $res->is_success; + }; -subtest 'wrong password' => sub { - my $test = Test::PAUSE::Web->tests_for('user'); - my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user, pass => "WRONG PASS"); - my $res = $t->get("$path");; - ok !$res->is_success; - is $res->code => HTTP_UNAUTHORIZED; -}; + subtest 'wrong password' => sub { + my $test = Test::PAUSE::Web->tests_for('user'); + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user, pass => "WRONG PASS"); + my $res = $t->get("$path"); + ok !$res->is_success; + is $res->code => HTTP_UNAUTHORIZED; + }; -subtest 'unknown user' => sub { - my $test = Test::PAUSE::Web->tests_for('user'); - my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => "UNKNOWN"); - my $res = $t->get("$path");; - ok !$res->is_success; - is $res->code => HTTP_UNAUTHORIZED; -}; + subtest 'unknown user' => sub { + my $test = Test::PAUSE::Web->tests_for('user'); + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => "UNKNOWN"); + my $res = $t->get("$path"); + ok !$res->is_success; + is $res->code => HTTP_UNAUTHORIZED; + }; + + subtest 'disallowed action for an anonymous user' => sub { + my $test = Test::PAUSE::Web->tests_for('user'); + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new; + my $res = $t->get("/pause/authenquery/?ACTION=add_user"); + ok !$res->is_success; + is $res->code => HTTP_UNAUTHORIZED; + }; -subtest 'disallowed action for an anonymous user' => sub { - my $test = Test::PAUSE::Web->tests_for('user'); - my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new; - my $res = $t->get("/authenquery/?ACTION=add_user");; - ok !$res->is_success; - is $res->code => HTTP_FORBIDDEN; + subtest 'disallowed action for a user' => sub { + my $test = Test::PAUSE::Web->tests_for('user'); + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + my $res = $t->get("/pause/authenquery/?ACTION=add_user"); + ok !$res->is_success; + is $res->code => HTTP_FORBIDDEN; + }; }; -subtest 'disallowed action for a user' => sub { - my $test = Test::PAUSE::Web->tests_for('user'); - my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new(user => $user); - my $res = $t->get("/authenquery/?ACTION=add_user");; - ok !$res->is_success; - is $res->code => HTTP_FORBIDDEN; +subtest 'for 2025 app' => sub { + subtest 'basic' => sub { + my $test = Test::PAUSE::Web->tests_for('user'); + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new; + my $res = $t->login(user => $user); + ok $res->is_success; + ok my @redirects = $res->redirects, "login succeeded and redirected"; + is $redirects[0]->header('Location')->path => '/'; + }; + + subtest 'lower case' => sub { + my $test = Test::PAUSE::Web->tests_for('user'); + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => lc $user); + my $res = $t->login(user => lc $user); + ok $res->is_success; + ok my @redirects = $res->redirects, "login succeeded and redirected"; + is $redirects[0]->header('Location')->path => '/'; + }; + + subtest 'wrong password' => sub { + my $test = Test::PAUSE::Web->tests_for('user'); + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new; + my $res = $t->login(user => $user, pass => "WRONG PASS"); + ok !(my @redirects = $res->redirects), "login failed and not redirected"; + }; + + subtest 'unknown user' => sub { + my $test = Test::PAUSE::Web->tests_for('user'); + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new; + my $res = $t->login(user => "UNKNOWN"); + ok !(my @redirects = $res->redirects), "login failed and not redirected"; + }; + + subtest 'disallowed action for an anonymous user' => sub { + my $test = Test::PAUSE::Web->tests_for('user'); + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new; + my $res = $t->get("/admin/add_user"); + ok !$res->is_success; + is $res->code => HTTP_FORBIDDEN; + }; + + subtest 'disallowed action for a user' => sub { + my $test = Test::PAUSE::Web->tests_for('user'); + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + my $res = $t->get("/admin/add_user"); + ok !$res->is_success; + is $res->code => HTTP_FORBIDDEN; + }; }; done_testing; diff --git a/t/pause_2025/lib/Test/PAUSE/Web.pm b/t/pause_2025/lib/Test/PAUSE/Web.pm index 34b6338a1..0704514de 100644 --- a/t/pause_2025/lib/Test/PAUSE/Web.pm +++ b/t/pause_2025/lib/Test/PAUSE/Web.pm @@ -26,7 +26,7 @@ our @EXPORT = @Test::More::EXPORT; our $FilenameToUpload = "Hash-RenameKey-0.02.tar.gz"; our $FileToUpload = "$AppRoot/t/staging/$FilenameToUpload"; -push @INC, "$AppRoot/lib", "$AppRoot/lib/pause_2017", "$AppRoot/privatelib"; +push @INC, "$AppRoot/lib", "$AppRoot/lib/pause_2025", "$AppRoot/lib/pause_2017", "$AppRoot/privatelib"; $TmpDir->child($_)->mkpath for qw/rundata incoming etc public log/; $TmpDir->child('log')->child('paused.log')->touch(); @@ -35,7 +35,7 @@ $INC{"PrivatePAUSE.pm"} = 1; $ENV{EMAIL_SENDER_TRANSPORT} = "Test"; require PAUSE; -require PAUSE::Web::Config; +require PAUSE::Web2025::Config; $PAUSE::Config->{DOCUMENT_ROOT} = "$AppRoot/htdocs"; $PAUSE::Config->{PID_DIR} = $TestRoot; @@ -145,7 +145,7 @@ sub reset_fixture { sub new { my ($class, %args) = @_; - my $psgi = $ENV{TEST_PAUSE_WEB_PSGI} // "app_2017.psgi"; + my $psgi = $ENV{TEST_PAUSE_WEB_PSGI} // "app_2025.psgi"; my $app = do "$AppRoot/$psgi"; $args{mech} = Test::WWW::Mechanize::PSGI->new(app => $app, cookie_jar => {}); @@ -161,8 +161,19 @@ sub new { sub set_credentials { my $self = shift; + return unless $self->{user}; note "log in as ".$self->{user}; $self->{mech}->credentials($self->{user}, $self->{pass}); + $self->{mech}->{env}{REMOTE_USER} = $self->{user}; +} + +sub login { + my ($self, %args) = @_; + my $user = $args{user} or return; + my $pass = $args{pass} || 'test'; + note "log in as $user"; + $self->{mech}->get('/login'); + $self->{mech}->submit_form(fields => {pause_id => $user, password => $pass}); } sub get { @@ -300,6 +311,17 @@ sub text_unlike { $self; } +sub dom_not_found { + my ($self, $selector) = @_; + my $at = $self->dom->at($selector); + if ($at) { + fail "'$selector' is found"; + } else { + pass "'$selector' is not found"; + } + $self; +} + sub title_is_ok { my ($self, $url) = @_; return if $self->dom->at('p.error_message'); # ignore if error @@ -308,7 +330,7 @@ sub title_is_ok { my ($action) = $url =~ /ACTION=(\w+)/; $action ||= $url; # in case action is passed as url return if $action =~ /^select_(user|ml_action)$/; - my $conf = PAUSE::Web::Config->action($action); + my $conf = PAUSE::Web2025::Config->action($action); return if $conf->{has_title}; # uses different title from its data source my $title = $conf->{verb}; @@ -423,6 +445,7 @@ sub reset_module_fixture { my $userdir = _userdir($dist->{owner}); $self->mod_db->insert("packages", { package => $package, + lc_package => lc $package, version => '0.01', dist => "$userdir/$dist->{name}-0.01.tar.gz", distname => $dist->{name}, @@ -432,6 +455,7 @@ sub reset_module_fixture { }); $self->mod_db->insert("primeur", { package => $package, + lc_package => lc $package, userid => $dist->{owner}, }); } @@ -441,6 +465,7 @@ sub reset_module_fixture { for my $package (@$packages) { $self->mod_db->insert("perms", { package => $package, + lc_package => lc $package, userid => $id, }); } @@ -448,6 +473,7 @@ sub reset_module_fixture { for my $package (@{$dist->{packages}}) { $self->mod_db->insert("perms", { package => $package, + lc_package => lc $package, userid => $comaint, }); } diff --git a/t/pause_2025/logout.t b/t/pause_2025/logout.t index e3e4b92ed..008ec23e9 100644 --- a/t/pause_2025/logout.t +++ b/t/pause_2025/logout.t @@ -7,38 +7,56 @@ use HTTP::Status qw/:constants/; Test::PAUSE::Web->setup; -subtest 'logout 1: redirect with Cookie' => sub { - for my $test (Test::PAUSE::Web->tests_for('user')) { - my ($path, $user) = @$test; - my $rand = rand 1; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path"); - my $res = $t->get("$path?logout=1$rand"); - is $res->code => HTTP_UNAUTHORIZED; - } -}; +subtest 'for 2017 app' => sub { + subtest 'logout 1: redirect with Cookie' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $rand = rand 1; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path"); + my $res = $t->get("$path?logout=1$rand"); + is $res->code => HTTP_UNAUTHORIZED; + } + }; + + subtest 'logout 2: redirect to Badname:Badpass@Server URL' => sub { + plan skip_all => "WWW::Mechanize/LWP::UserAgent currently ignores userinfo"; + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $rand = rand 1; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path"); + my $res = $t->get("$path?logout=2$rand"); + is $res->code => HTTP_UNAUTHORIZED; + } + }; -subtest 'logout 2: redirect to Badname:Badpass@Server URL' => sub { - plan skip_all => "WWW::Mechanize/LWP::UserAgent currently ignores userinfo"; - for my $test (Test::PAUSE::Web->tests_for('user')) { - my ($path, $user) = @$test; - my $rand = rand 1; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path"); - my $res = $t->get("$path?logout=2$rand"); - is $res->code => HTTP_UNAUTHORIZED; - } + subtest 'logout 3: Quick direct 401' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $rand = rand 1; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path"); + my $res = $t->get("$path?logout=3$rand"); + is $res->code => HTTP_UNAUTHORIZED; + } + }; }; -subtest 'logout 3: Quick direct 401' => sub { - for my $test (Test::PAUSE::Web->tests_for('user')) { - my ($path, $user) = @$test; - my $rand = rand 1; - my $t = Test::PAUSE::Web->new(user => $user); - $t->get_ok("$path"); - my $res = $t->get("$path?logout=3$rand"); - is $res->code => HTTP_UNAUTHORIZED; - } +subtest 'for 2025 app' => sub { + # there's only one way to logout + subtest 'logout' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $rand = rand 1; + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/logout"); + $t->post_with_token_ok("/user/logout", {SUBMIT => 'Logout'}); + my $res = $t->get("/user/logout"); + is $res->code => HTTP_FORBIDDEN; + } + }; }; done_testing; From 3ceb1c65c280e14e64e7b8b893eca607069334a9 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Fri, 2 May 2025 16:40:13 +0900 Subject: [PATCH 44/51] Update cpanfile --- cpanfile | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/cpanfile b/cpanfile index 1580c3568..2458043be 100644 --- a/cpanfile +++ b/cpanfile @@ -1,4 +1,5 @@ requires 'Apache::Session::Counted'; +requires 'Auth::GoogleAuth', '1.05'; requires 'BSD::Resource'; requires 'CPAN::Checksums', '1.050'; requires 'CPAN::DistnameInfo'; @@ -34,7 +35,7 @@ requires 'Log::Dispatchouli'; requires 'Module::Signature'; requires 'MojoX::Log::Dispatch::Simple'; requires 'Mojolicious'; -requires 'Mojolicious::Plugin::WithCSRFProtection'; +requires 'Mojolicious::Plugin::WithCSRFProtection', '1.02'; requires 'Net::SSLeay', '1.49'; requires 'Parallel::Runner'; requires 'Parse::CPAN::Packages'; From c342be96435bf2a2be030941551bc5f6a406b23d Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Fri, 2 May 2025 16:44:17 +0900 Subject: [PATCH 45/51] Ignore WithCSRFProtection 1.02 for now --- cpanfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cpanfile b/cpanfile index 2458043be..1886fa860 100644 --- a/cpanfile +++ b/cpanfile @@ -35,7 +35,7 @@ requires 'Log::Dispatchouli'; requires 'Module::Signature'; requires 'MojoX::Log::Dispatch::Simple'; requires 'Mojolicious'; -requires 'Mojolicious::Plugin::WithCSRFProtection', '1.02'; +requires 'Mojolicious::Plugin::WithCSRFProtection'; #, '1.02'; requires 'Net::SSLeay', '1.49'; requires 'Parallel::Runner'; requires 'Parse::CPAN::Packages'; From 930b1400afe115df5ddf2fdee9544a43ae827fce Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Fri, 2 May 2025 16:47:26 +0900 Subject: [PATCH 46/51] Requires Image::QRCode as well --- cpanfile | 1 + 1 file changed, 1 insertion(+) diff --git a/cpanfile b/cpanfile index 1886fa860..53a8f56e1 100644 --- a/cpanfile +++ b/cpanfile @@ -23,6 +23,7 @@ requires 'HTML::Entities'; requires 'HTTP::Date'; requires 'HTTP::Status'; requires 'HTTP::Tiny', '0.059'; +requires 'Imager::QRCode'; requires 'IO::Socket::SSL', '1.56'; requires 'IPC::Run3'; requires 'JSON'; From a25722e98d1e7d783bc513a713ee96fc54dbb04f Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Fri, 2 May 2025 18:09:54 +0900 Subject: [PATCH 47/51] No need to escape a question mark here --- t/pause_2025/action_2025/add_uri.t | 22 ---------------------- t/pause_2025/action_2025/add_user.t | 2 +- 2 files changed, 1 insertion(+), 23 deletions(-) diff --git a/t/pause_2025/action_2025/add_uri.t b/t/pause_2025/action_2025/add_uri.t index 5d8901105..e911c50e0 100644 --- a/t/pause_2025/action_2025/add_uri.t +++ b/t/pause_2025/action_2025/add_uri.t @@ -130,28 +130,6 @@ subtest 'post: under a Perl6 subdir' => sub { } }; -subtest 'post: move error' => sub { - for my $test (Test::PAUSE::Web->tests_for('user')) { - my ($path, $user) = @$test; - my $t = Test::PAUSE::Web->new; - $t->login(user => $user); - my %form = %$http_upload; - rmtree($PAUSE::Config->{INCOMING_LOC}); - - $t->mod_dbh->do('TRUNCATE uris'); - $t->post_ok("/user/add_uri", \%form, "Content-Type" => "form-data"); - $t->text_like('.error_message' => qr/Couldn't copy file/); - - my $rows = $t->mod_db->select('uris', ['*'], { - userid => $user, - uri => $form{pause99_add_uri_httpupload}[1], - }); - is @$rows => 0; - - mkpath($PAUSE::Config->{INCOMING_LOC}); - } -}; - subtest 'post: empty' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { my ($path, $user) = @$test; diff --git a/t/pause_2025/action_2025/add_user.t b/t/pause_2025/action_2025/add_user.t index 500df039e..55c21afd2 100644 --- a/t/pause_2025/action_2025/add_user.t +++ b/t/pause_2025/action_2025/add_user.t @@ -273,7 +273,7 @@ subtest 'get: retrieve a stored session' => sub { like $userid => qr/\A\d+_\w+\z/; $t->clear_deliveries; - $t->get_ok("/admin/add_user\?USERID=$userid"); + $t->get_ok("/admin/add_user?USERID=$userid"); # note $t->content; for my $key (keys %$new_user) { From 70b42e48fcb012a25ed23e8e4fab8465cf5ff214 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sun, 4 May 2025 23:03:52 +0900 Subject: [PATCH 48/51] Remove ::App::Index from app_2025.psgi as we don't use it, as well as PAUSE::Web2025::App::Index --- app_2025.psgi | 1 - lib/pause_2025/PAUSE/Web2025/App/Index.pm | 61 ----------------------- 2 files changed, 62 deletions(-) delete mode 100644 lib/pause_2025/PAUSE/Web2025/App/Index.pm diff --git a/app_2025.psgi b/app_2025.psgi index 010ecd164..f7d7c908d 100644 --- a/app_2025.psgi +++ b/app_2025.psgi @@ -16,7 +16,6 @@ $ENV{MOJO_HOME} = $AppRoot; # preload stuff use PAUSE::Web::Context; use PAUSE::Web; -use PAUSE::Web::App::Index; use PAUSE::Web::App::Disabled; use PAUSE::Web2025; use PAUSE::Web2025::Context; diff --git a/lib/pause_2025/PAUSE/Web2025/App/Index.pm b/lib/pause_2025/PAUSE/Web2025/App/Index.pm deleted file mode 100644 index 2d158ee67..000000000 --- a/lib/pause_2025/PAUSE/Web2025/App/Index.pm +++ /dev/null @@ -1,61 +0,0 @@ -package PAUSE::Web2025::App::Index; - -use Mojo::Base -base; -use Plack::Request; -use Plack::Response; -use HTTP::Status qw/:constants/; - -sub to_app { - my $self = shift; - - return sub { - my $req = Plack::Request->new(shift); - my $res = $self->dispatch($req); - return $res if ref $res; - [$res =~ /^\d+$/ ? $res : 500, [], [$res]]; - }; -} - - -sub dispatch { - my ($self, $req) = @_; - - my $method = $req->method; - my $redir_to = $req->base; - my $is_ssl = $req->headers->header("X-pause-is-SSL") || 1; - if ($is_ssl) { - $redir_to->scheme("https"); - } - if ($method eq "GET" && $redir_to->path eq "/" && $req->env->{QUERY_STRING}) { - my $args = $req->env->{QUERY_STRING}; - # warn "Returning SERVER_ERROR: the_request[$the_request]uri[$uri]args[$args]"; - # return SERVER_ERROR; - $redir_to->path("/pause/query"); - $args =~ s|/$||; - $args =~ s|\s.*||; - $redir_to->query($args) if $args; - # warn "Statistics: Redirecting the_request[$the_request]redir_to[$redir_to]"; - my $res = $req->new_response(HTTP_MOVED_PERMANENTLY); - $res->headers->header("Location", $redir_to); - return $res->finalize; - } - - my $uri = $req->path; - #my $host = $r->server->server_hostname; - #my $args = $r->args; - #warn "index-uri[$uri]host[$host]args[$args]"; - return HTTP_NOT_FOUND unless $uri eq "/" || $uri eq "/index.html"; - - #my(%redir) = ( - # "/" => "query", - # "/index.html" => "query?ACTION=pause_05news", - # ); - # $r->internal_redirect_handler("/query"); - $redir_to->path("/pause/query"); - $redir_to->query("ACTION=pause_05news") if $uri eq "/index.html"; - my $res = $req->new_response(HTTP_MOVED_PERMANENTLY); - $res->headers->header("Location", $redir_to); - return $res->finalize; -} - -1; From f7c47f635966ba3b4bcdfd732277d94cae7e3725 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sun, 4 May 2025 23:05:39 +0900 Subject: [PATCH 49/51] Update schema --- doc/authen_pause.schema.txt | 3 +++ doc/schemas/authen_pause.schema.sqlite | 3 +++ 2 files changed, 6 insertions(+) diff --git a/doc/authen_pause.schema.txt b/doc/authen_pause.schema.txt index 00b335dc8..450ed8205 100644 --- a/doc/authen_pause.schema.txt +++ b/doc/authen_pause.schema.txt @@ -56,6 +56,9 @@ CREATE TABLE usertable ( `changed` int(11) DEFAULT NULL, changedby char(10) DEFAULT NULL, lastvisit datetime DEFAULT NULL, + mfa tinyint(1) DEFAULT 0, + mfa_secret32 varchar(16) DEFAULT NULL, + mfa_recovery_codes text DEFAULT NULL, PRIMARY KEY (`user`), KEY usertable_password (`password`) ) ENGINE=InnoDB DEFAULT CHARSET=latin1 PACK_KEYS=1; diff --git a/doc/schemas/authen_pause.schema.sqlite b/doc/schemas/authen_pause.schema.sqlite index 189abb95a..36ae5725b 100644 --- a/doc/schemas/authen_pause.schema.sqlite +++ b/doc/schemas/authen_pause.schema.sqlite @@ -36,6 +36,9 @@ CREATE TABLE usertable ( changed int(11) DEFAULT NULL, changedby char(10) DEFAULT NULL, lastvisit datetime DEFAULT NULL, + mfa tinyint(1) DEFAULT 0, + mfa_secret32 varchar(16) DEFAULT NULL, + mfa_recovery_codes text DEFAULT NULL, PRIMARY KEY (user) ); From eb49aa223be412fa8e08d21e060a886f15c5073c Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sun, 4 May 2025 23:19:20 +0900 Subject: [PATCH 50/51] Apply the same changes done for pause_2017 files to pause_2025 files --- lib/pause_2025/PAUSE/Web2025/Config.pm | 16 ++- .../PAUSE/Web2025/Controller/Admin.pm | 44 ++++++++ .../PAUSE/Web2025/Controller/User.pm | 2 +- .../PAUSE/Web2025/Controller/User/Files.pm | 15 ++- .../PAUSE/Web2025/Plugin/ConfigPerRequest.pm | 2 +- .../PAUSE/Web2025/Plugin/RenderYAML.pm | 4 + .../admin/change_user_status.html.ep | 19 ++++ .../email/admin/change_user_status.email.ep | 13 +++ lib/pause_2025/templates/public/admin.html.ep | 1 - .../templates/public/pumpkin.html.ep | 1 - .../templates/user/distperms/peek.html.ep | 3 +- .../templates/user/files/delete.html.ep | 17 ++- .../templates/user/files/show.html.ep | 4 +- .../templates/user/perms/peek.html.ep | 3 +- .../user/perms/remove_primary.html.ep | 2 +- lib/pause_2025/templates/user/uri/add.html.ep | 5 +- t/pause_2025/action_2017/change_user_status.t | 98 +++++++++++++++++ t/pause_2025/action_2017/make_comaint.t | 1 - t/pause_2025/action_2025/change_user_status.t | 104 ++++++++++++++++++ t/pause_2025/action_2025/logout.t | 19 ++++ t/pause_2025/lib/Test/PAUSE/MySQL.pm | 12 -- 21 files changed, 350 insertions(+), 35 deletions(-) create mode 100644 lib/pause_2025/templates/admin/change_user_status.html.ep create mode 100644 lib/pause_2025/templates/email/admin/change_user_status.email.ep create mode 100644 t/pause_2025/action_2017/change_user_status.t create mode 100644 t/pause_2025/action_2025/change_user_status.t create mode 100644 t/pause_2025/action_2025/logout.t diff --git a/lib/pause_2025/PAUSE/Web2025/Config.pm b/lib/pause_2025/PAUSE/Web2025/Config.pm index f4dd794c1..da76f96c4 100644 --- a/lib/pause_2025/PAUSE/Web2025/Config.pm +++ b/lib/pause_2025/PAUSE/Web2025/Config.pm @@ -572,11 +572,25 @@ our %Actions = ( cat => "01usr/01look", desc => "Admins can look where email should go", }, + change_user_status => { + x_mojo_to => "admin#change_user_status", + verb => "Change user status", + priv => "admin", + cat => "01usr/03", + desc => "Admins can change the ustatus of a user", + x_csrf_protection => 1, + x_form => { + HIDDENNAME => {form_type => "hidden_field"}, + pause99_change_user_status_user => {form_type => "text_field"}, + pause99_change_user_status_new_ustatus => {form_type => "select_field"}, + pause99_change_user_status_sub => {form_type => "submit_button"}, + }, + }, select_user => { x_mojo_to => "admin#select_user", verb => "Select User/Action", priv => "admin", - cat => "01usr/03", + cat => "01usr/04", desc => "Admins can access PAUSE as-if they were somebody else. Here they select a user/action pair.", method => 'POST', x_form => { diff --git a/lib/pause_2025/PAUSE/Web2025/Controller/Admin.pm b/lib/pause_2025/PAUSE/Web2025/Controller/Admin.pm index 56c89ba6f..e34b3b8d2 100644 --- a/lib/pause_2025/PAUSE/Web2025/Controller/Admin.pm +++ b/lib/pause_2025/PAUSE/Web2025/Controller/Admin.pm @@ -167,6 +167,50 @@ sub edit_ml { } } +sub change_user_status { + my $c = shift; + my $pause = $c->stash(".pause"); + my $mgr = $c->app->pause; + my $req = $c->req; + my $u = $c->active_user_record; + + my %valid_status = map {$_ => 1} qw(active nologin); + + my $user = $req->param("pause99_change_user_status_user"); + my $new_ustatus = $req->param("pause99_change_user_status_new_ustatus"); + if ($user) { + $pause->{user} = uc $user; + my $dbh = $mgr->connect; + my $sql = qq{SELECT ustatus FROM users WHERE userid = ?}; + my $row = $dbh->selectrow_arrayref($sql, undef, uc $user); + if ($row) { + $pause->{ustatus} = $row->[0]; + } else { + $pause->{user_not_found} = 1; + return; + } + + if ($new_ustatus && $valid_status{$new_ustatus} && $new_ustatus ne $pause->{ustatus}) { + my $sql = qq{UPDATE users SET ustatus = ?, changed = ?, changedby = ? WHERE userid = ?}; + my $sth = $dbh->prepare($sql); + my $ret = $sth->execute($new_ustatus, time, $u->{userid}, uc $user); + $sth->finish; + if ($ret) { + $pause->{changed} = 1; + $pause->{new_ustatus} = $new_ustatus; + my $mailblurb = $c->render_to_string("email/admin/change_user_status", format => "email"); + my @to = ($u->{secretemail}||$u->{email}, $mgr->config->mailto_admins); + warn "sending to[@to]"; + warn "mailblurb[$mailblurb]"; + my $header = { + Subject => "User status update for $user" + }; + $mgr->send_mail_multi(\@to, $header, $mailblurb); + } + } + } +} + sub select_user { my $c = shift; my $pause = $c->stash(".pause"); diff --git a/lib/pause_2025/PAUSE/Web2025/Controller/User.pm b/lib/pause_2025/PAUSE/Web2025/Controller/User.pm index cbabf1fe8..d9ae20b16 100644 --- a/lib/pause_2025/PAUSE/Web2025/Controller/User.pm +++ b/lib/pause_2025/PAUSE/Web2025/Controller/User.pm @@ -218,7 +218,7 @@ sub reindex { foreach my $f (keys %files) { if ( - $f =~ /readme$/ || + $f =~ /\.(?:readme|meta)$/ || $f eq "CHECKSUMS" ) { delete $files{$f}; diff --git a/lib/pause_2025/PAUSE/Web2025/Controller/User/Files.pm b/lib/pause_2025/PAUSE/Web2025/Controller/User/Files.pm index c3ec9d771..f6af15c0b 100644 --- a/lib/pause_2025/PAUSE/Web2025/Controller/User/Files.pm +++ b/lib/pause_2025/PAUSE/Web2025/Controller/User/Files.pm @@ -4,6 +4,7 @@ use Mojo::Base "Mojolicious::Controller"; use HTTP::Date (); use File::pushd; use PAUSE (); +use CPAN::DistnameInfo; sub show { my $c = shift; @@ -48,10 +49,11 @@ sub show { warn "ALERT: Could not stat f[$f]: $!"; next; } + my $modified = (stat _)[9]; my $blurb = $deletes{$f} ? $c->scheduled($whendele{$f}) : - HTTP::Date::time2str((stat _)[9]); - $files{$f} = {stat => -s _, blurb => $blurb, indexed => $indexed->{$f} }; + HTTP::Date::time2str($modified); + $files{$f} = {stat => -s _, blurb => $blurb, indexed => $indexed->{$f}, modified => $modified }; } $pause->{files} = \%files; } @@ -172,10 +174,15 @@ sub delete { warn "ALERT: Could not stat f[$f]: $!"; next; } + my $tmpf = $f; + $tmpf =~ s/\.(?:readme|meta)$/.tar.gz/; + my $info = CPAN::DistnameInfo->new($tmpf); + my $distv = $info->distvname; + my $modified = (stat _)[9]; my $blurb = $deletes{$f} ? $c->scheduled($whendele{$f}) : - HTTP::Date::time2str((stat _)[9]); - $files{$f} = {stat => -s _, blurb => $blurb, indexed => $indexed->{$f} }; + HTTP::Date::time2str($modified); + $files{$f} = {stat => -s _, blurb => $blurb, indexed => $indexed->{$f}, distv => $distv, modified => $modified }; $pause->{deleting_indexed_files} = 1 if $deletes{$f} && $indexed->{$f}; } $pause->{files} = \%files; diff --git a/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm index 7155f685a..4d3a09790 100644 --- a/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/ConfigPerRequest.pm @@ -83,7 +83,7 @@ sub _retrieve_user { $sth7->execute($user); my $error; if ($sth7->rows > 0) { - $error = "User '$user' set to nologin. Many users with an insecure password have got their password reset recently because of an incident on perlmonks.org. Please talk to modules\@perl.org to find out how to proceed"; + $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"; } diff --git a/lib/pause_2025/PAUSE/Web2025/Plugin/RenderYAML.pm b/lib/pause_2025/PAUSE/Web2025/Plugin/RenderYAML.pm index 24c134c09..0ff988936 100644 --- a/lib/pause_2025/PAUSE/Web2025/Plugin/RenderYAML.pm +++ b/lib/pause_2025/PAUSE/Web2025/Plugin/RenderYAML.pm @@ -12,6 +12,10 @@ sub register { local $YAML::Syck::ImplicitUnicode = 1; my $dump = YAML::Syck::Dump($data); my $edump = Encode::encode_utf8($dump); + my $action = $c->req->param('ACTION') || 'pause'; + $action =~ tr/a-z0-9_//cd; + $c->res->headers->content_disposition("attachment; filename=$action.yaml"); + $c->res->headers->content_type('application/yaml'); $c->stash(format => "text"); $c->render(text => $edump); return; diff --git a/lib/pause_2025/templates/admin/change_user_status.html.ep b/lib/pause_2025/templates/admin/change_user_status.html.ep new file mode 100644 index 000000000..36d51f0bd --- /dev/null +++ b/lib/pause_2025/templates/admin/change_user_status.html.ep @@ -0,0 +1,19 @@ +% layout 'layout'; +% my $pause = stash(".pause") || {}; + + + +% if ($pause->{user_not_found}) { +
+

User <%= $pause->{user} %> is not found.

+
+% } elsif ($pause->{changed}) { +
+

<%= $pause->{user} %>'s status has changed from <%= $pause->{ustatus} %> to <%= $pause->{new_ustatus} %>.

+
+% } + +%= csrf_field +%= text_field "pause99_change_user_status_user" => $pause->{user}; +%= select_field "pause99_change_user_status_new_ustatus" => ['nologin', 'active']; +%= submit_button "Change", name => "pause99_change_user_status_sub"; diff --git a/lib/pause_2025/templates/email/admin/change_user_status.email.ep b/lib/pause_2025/templates/email/admin/change_user_status.email.ep new file mode 100644 index 000000000..a3b87cec3 --- /dev/null +++ b/lib/pause_2025/templates/email/admin/change_user_status.email.ep @@ -0,0 +1,13 @@ +% my $pause = stash(".pause") || {}; +% +%#------------------------------------------------------------------ +% +Record update in the PAUSE users database: + +The ustatus of <%= $pause->{user} %> has changed from <%= $pause->{ustatus} %> to <%= $pause->{new_ustatus} %>. + +Data entered by <%= $pause->{User}{fullname} %>. + +Thanks, +-- +The PAUSE Team diff --git a/lib/pause_2025/templates/public/admin.html.ep b/lib/pause_2025/templates/public/admin.html.ep index 461079328..fe9fdc51e 100644 --- a/lib/pause_2025/templates/public/admin.html.ep +++ b/lib/pause_2025/templates/public/admin.html.ep @@ -1,7 +1,6 @@ % layout 'layout'; % my $pause = stash(".pause") || {}; -

Query the grouptable table for who is an admin bit holder

Registered admins: <%= join ", ", @{$pause->{admins} || []} %>

"YAML") %>" style="text-decoration: none;"> YAML diff --git a/lib/pause_2025/templates/public/pumpkin.html.ep b/lib/pause_2025/templates/public/pumpkin.html.ep index f267edf79..737cf794a 100644 --- a/lib/pause_2025/templates/public/pumpkin.html.ep +++ b/lib/pause_2025/templates/public/pumpkin.html.ep @@ -1,7 +1,6 @@ % layout 'layout'; % my $pause = stash(".pause") || {}; -

Query the grouptable table for who is a pumpkin bit holder

Registered pumpkins: <%= join ", ", @{$pause->{pumpkins} || []} %>

"YAML") %>" style="text-decoration: none;"> YAML diff --git a/lib/pause_2025/templates/user/distperms/peek.html.ep b/lib/pause_2025/templates/user/distperms/peek.html.ep index 6d3d8b0ab..b560e1c4f 100644 --- a/lib/pause_2025/templates/user/distperms/peek.html.ep +++ b/lib/pause_2025/templates/user/distperms/peek.html.ep @@ -1,8 +1,7 @@ % layout 'layout'; % my $pause = stash(".pause") || {}; -

Query the perms table by author or by -distribution. Select the option and fill in a distribution name or +

Select the option and fill in a distribution name or user ID as appropriate. The answer is all distributions that an user ID is registered for or all user IDs registered for a distribution, as appropriate.

diff --git a/lib/pause_2025/templates/user/files/delete.html.ep b/lib/pause_2025/templates/user/files/delete.html.ep index d53a8354c..dbc87de9f 100644 --- a/lib/pause_2025/templates/user/files/delete.html.ep +++ b/lib/pause_2025/templates/user/files/delete.html.ep @@ -29,14 +29,14 @@ % for my $file (sort keys %$files) { - <%= check_box "pause99_delete_files_FILE" => $file %> + <%= check_box "pause99_delete_files_FILE" => $file, 'data-distv' => $files->{$file}{distv} %> % if ($files->{$file}{indexed}) { <%= $file %> [indexed] % } else { <%= $file %> % } <%= $files->{$file}{stat} %> - <%= $files->{$file}{blurb} %> + <%= $files->{$file}{blurb} %> % } @@ -48,8 +48,19 @@ %= javascript "/pause/list.min.js" %= javascript begin var List = new List('files', { - valueNames: ['file', 'size', 'modified'] + valueNames: ['file', 'size', { name: 'modified', attr: 'data-modified' }] }); + +document.querySelectorAll('input[type=checkbox]').forEach(function(e) { + e.addEventListener('change', function(ev) { + var checked = ev.currentTarget.checked; + var distv = ev.currentTarget.getAttribute('data-distv'); + document.querySelectorAll('input[data-distv="'+distv+'"]').forEach(function(e) { + e.checked = checked; + }); + }) +}); + % end % end diff --git a/lib/pause_2025/templates/user/files/show.html.ep b/lib/pause_2025/templates/user/files/show.html.ep index de31614d7..ecdb54e45 100644 --- a/lib/pause_2025/templates/user/files/show.html.ep +++ b/lib/pause_2025/templates/user/files/show.html.ep @@ -23,7 +23,7 @@ <%= $file %> % } <%= $files->{$file}{stat} %> - <%= $files->{$file}{blurb} %> + <%= $files->{$file}{blurb} %> % } @@ -33,7 +33,7 @@ %= javascript "/pause/list.min.js" %= javascript begin var List = new List('files', { - valueNames: ['file', 'size', 'modified'] + valueNames: ['file', 'size', { name: 'modified', attr: 'data-modified' }] }); % end % end diff --git a/lib/pause_2025/templates/user/perms/peek.html.ep b/lib/pause_2025/templates/user/perms/peek.html.ep index e72d0c28d..6e169b00e 100644 --- a/lib/pause_2025/templates/user/perms/peek.html.ep +++ b/lib/pause_2025/templates/user/perms/peek.html.ep @@ -1,8 +1,7 @@ % layout 'layout'; % my $pause = stash(".pause") || {}; -

Query the perms table by author or by -module. Select the option and fill in a module name or +

Select the option and fill in a module name or user ID as appropriate. The answer is all modules that an user ID is registered for or all user IDs registered for a module, as appropriate.

diff --git a/lib/pause_2025/templates/user/perms/remove_primary.html.ep b/lib/pause_2025/templates/user/perms/remove_primary.html.ep index e36a79fcb..2e56d5274 100644 --- a/lib/pause_2025/templates/user/perms/remove_primary.html.ep +++ b/lib/pause_2025/templates/user/perms/remove_primary.html.ep @@ -45,7 +45,7 @@ to one of the other owners.

If you have are unsure about what to do, or have any questions, -please email the PAUSE admins at modules@cpan.org. +please email the PAUSE admins at modules@perl.org.

If you want to give up all the modules in a distribution, visit diff --git a/lib/pause_2025/templates/user/uri/add.html.ep b/lib/pause_2025/templates/user/uri/add.html.ep index 1e484ad13..d2d59be85 100644 --- a/lib/pause_2025/templates/user/uri/add.html.ep +++ b/lib/pause_2025/templates/user/uri/add.html.ep @@ -56,8 +56,7 @@ you do not seem to want HTTP upload enabled, we do % }

GET URL: PAUSE fetches any http or ftp -URL that can be handled by LWP (Note: https is currently not -supported): use the text field (please specify the complete +URL that can be handled by LWP: use the text field (please specify the complete URL).

Please, make sure your filename @@ -127,7 +126,7 @@ to your homedirectory:

<%= text_field "pause99_add_uri_uri", size => 64, - maxlength => 128, + maxlength => 255, %>

diff --git a/t/pause_2025/action_2017/change_user_status.t b/t/pause_2025/action_2017/change_user_status.t new file mode 100644 index 000000000..f5a6fbaa1 --- /dev/null +++ b/t/pause_2025/action_2017/change_user_status.t @@ -0,0 +1,98 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; + +my $default = { + pause99_change_user_status_user => "TESTUSER", + pause99_change_user_status_new_ustatus => "nologin", + pause99_change_user_status_sub => 1, +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new(user => $user); + $t->get_ok("$path?ACTION=change_user_status"); + # note $t->content; + } +}; + +subtest 'post: basic' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my %form = %$default; + my $t = Test::PAUSE::Web->new(user => $user); + my $res = $t->post("$path?ACTION=change_user_status", \%form); + ok !$res->is_success && $res->code == 403, "Forbidden"; + like $res->content => qr/Failed CSRF check/; + # note $t->content; + } +}; + +subtest 'post_with_token: basic' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my %form = %$default; + my $t = Test::PAUSE::Web->new(user => $user); + $t->post_with_token_ok("$path?ACTION=change_user_status", \%form) + ->text_like("div.messagebox p", qr/status has changed from \w+ to nologin/); + is $t->deliveries => 2, "two deliveries for admin"; + # note $t->content; + } +}; + +subtest 'post_with_token: user not found' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my %form = ( + %$default, + pause99_change_user_status_user => 'UNKNOWN', + ); + my $t = Test::PAUSE::Web->new(user => $user); + $t->post_with_token_ok("$path?ACTION=change_user_status", \%form) + ->text_like("div.messagebox p", qr/User UNKNOWN is not found/); + is $t->deliveries => 0, "no deliveries for admin"; + # note $t->content; + } +}; + +subtest 'post_with_token: ustatus not changed' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my %form = %$default; + my $t = Test::PAUSE::Web->new(user => $user); + $t->post_with_token_ok("$path?ACTION=change_user_status", \%form) + ->text_like("div.messagebox p", qr/status has changed from \w+ to nologin/); + is $t->deliveries => 2, "two deliveries for admin"; + # note $t->content; + + # nologin to nologin + $t->post_with_token_ok("$path?ACTION=change_user_status", \%form) + ->dom_not_found("div.messagebox p"); + is $t->deliveries => 0, "no deliveries for admin"; + } +}; + +subtest 'post_with_token: unknown ustatus' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my %form = ( + %$default, + pause99_change_user_status_new_ustatus => 'unknown', + ); + my $t = Test::PAUSE::Web->new(user => $user); + $t->post_with_token_ok("$path?ACTION=change_user_status", \%form) + ->dom_not_found("div.messagebox p"); + is $t->deliveries => 0, "no deliveries for admin"; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2017/make_comaint.t b/t/pause_2025/action_2017/make_comaint.t index 0263244b6..42483c71c 100644 --- a/t/pause_2025/action_2017/make_comaint.t +++ b/t/pause_2025/action_2017/make_comaint.t @@ -83,7 +83,6 @@ subtest 'normal case' => sub { note $t->content; } }; -done_testing;exit; subtest 'unknown user' => sub { for my $test (Test::PAUSE::Web->tests_for('user')) { diff --git a/t/pause_2025/action_2025/change_user_status.t b/t/pause_2025/action_2025/change_user_status.t new file mode 100644 index 000000000..ae24f8ac4 --- /dev/null +++ b/t/pause_2025/action_2025/change_user_status.t @@ -0,0 +1,104 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; + +my $default = { + pause99_change_user_status_user => "TESTUSER", + pause99_change_user_status_new_ustatus => "nologin", + pause99_change_user_status_sub => 1, +}; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/admin/change_user_status"); + # note $t->content; + } +}; + +subtest 'post: basic' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my %form = %$default; + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + my $res = $t->post("/admin/change_user_status", \%form); + ok !$res->is_success && $res->code == 403, "Forbidden"; + like $res->content => qr/Failed CSRF check/; + # note $t->content; + } +}; + +subtest 'post_with_token: basic' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my %form = %$default; + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->post_with_token_ok("/admin/change_user_status", \%form) + ->text_like("div.messagebox p", qr/status has changed from \w+ to nologin/); + is $t->deliveries => 2, "two deliveries for admin"; + # note $t->content; + } +}; + +subtest 'post_with_token: user not found' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my %form = ( + %$default, + pause99_change_user_status_user => 'UNKNOWN', + ); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->post_with_token_ok("/admin/change_user_status", \%form) + ->text_like("div.messagebox p", qr/User UNKNOWN is not found/); + is $t->deliveries => 0, "no deliveries for admin"; + # note $t->content; + } +}; + +subtest 'post_with_token: ustatus not changed' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my %form = %$default; + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->post_with_token_ok("/admin/change_user_status", \%form) + ->text_like("div.messagebox p", qr/status has changed from \w+ to nologin/); + is $t->deliveries => 2, "two deliveries for admin"; + # note $t->content; + + # nologin to nologin + $t->post_with_token_ok("/admin/change_user_status", \%form) + ->dom_not_found("div.messagebox p"); + is $t->deliveries => 0, "no deliveries for admin"; + } +}; + +subtest 'post_with_token: unknown ustatus' => sub { + Test::PAUSE::Web->setup; + for my $test (Test::PAUSE::Web->tests_for('admin')) { + my ($path, $user) = @$test; + my %form = ( + %$default, + pause99_change_user_status_new_ustatus => 'unknown', + ); + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->post_with_token_ok("/admin/change_user_status", \%form) + ->dom_not_found("div.messagebox p"); + is $t->deliveries => 0, "no deliveries for admin"; + } +}; + +done_testing; diff --git a/t/pause_2025/action_2025/logout.t b/t/pause_2025/action_2025/logout.t new file mode 100644 index 000000000..4c706dc4f --- /dev/null +++ b/t/pause_2025/action_2025/logout.t @@ -0,0 +1,19 @@ +use Mojo::Base -strict; +use FindBin; +use lib "$FindBin::Bin/../lib"; +use Test::PAUSE::Web; +use utf8; + +Test::PAUSE::Web->setup; + +subtest 'get' => sub { + for my $test (Test::PAUSE::Web->tests_for('user')) { + my ($path, $user) = @$test; + my $t = Test::PAUSE::Web->new; + $t->login(user => $user); + $t->get_ok("/user/logout"); + # note $t->content; + } +}; + +done_testing; diff --git a/t/pause_2025/lib/Test/PAUSE/MySQL.pm b/t/pause_2025/lib/Test/PAUSE/MySQL.pm index 8a298f343..13ae4873a 100644 --- a/t/pause_2025/lib/Test/PAUSE/MySQL.pm +++ b/t/pause_2025/lib/Test/PAUSE/MySQL.pm @@ -21,18 +21,6 @@ use Path::Tiny; $SIG{INT} = sub { die "caught SIGINT, shutting down mysql\n" }; -=head2 SYNOPSIS - - my $db - = Test::PAUSE::MySQL->new( schemas => ['doc/mod.schema.txt'] ); - - my $dbh = $db->dbh; - - # Drop straight in to the mysql console: - $dbh->debug_console - -=cut - # These are the only caller-configurable parts # SQL to load at instantiation From 3c6160adf9c98b07fcbadf3d99fdd79e17690d89 Mon Sep 17 00:00:00 2001 From: Kenichi Ishigaki Date: Sun, 4 May 2025 23:20:07 +0900 Subject: [PATCH 51/51] Add a schemachange file --- one-off-utils/schemachange-2025-04.sql | 3 +++ 1 file changed, 3 insertions(+) create mode 100644 one-off-utils/schemachange-2025-04.sql diff --git a/one-off-utils/schemachange-2025-04.sql b/one-off-utils/schemachange-2025-04.sql new file mode 100644 index 000000000..b981d9722 --- /dev/null +++ b/one-off-utils/schemachange-2025-04.sql @@ -0,0 +1,3 @@ +ALTER TABLE usertable ADD COLUMN mfa tinyint(1) DEFAULT 0; +ALTER TABLE usertable ADD COLUMN mfa_secret32 varchar(16); +ALTER TABLE usertable ADD COLUMN mfa_recovery_codes text;