#!/usr/bin/env perl # Stands up a genuinely fresh tCMS in a temp dir, then walks the loop a user # actually performs: register an admin, invent a post type in the wizard, and # for each content post type build a topbar series, confirm it lands in the # nav, add a child post and confirm the child renders on the series page. # # Verification goes through Trog::Routes::HTML::index() -- directly, or via # series() which delegates to it -- and matches on the returned HTML. use strict; use warnings; # FindBin MUST come first. $FindBin::Bin is derived from $0, which prove hands # us relatively, and it is computed once. chdir before this loads and every # module's `use FindBin::libs` resolves against the sandbox instead of the repo. use FindBin; use lib "$FindBin::Bin/../lib"; use Test::More; use Cwd (); use Encode (); use File::Copy (); use File::Find (); use File::Path (); use File::Temp (); use Time::HiRes (); use URI::Escape (); use JSON::MaybeXS (); use File::Slurper (); our ( $REPO, $ROOT, $OLDCWD ); our %REPO_BEFORE; # Which data model this run exercises. Every assertion in this file is about # what the app does, not how it stores anything, so all of them have to hold for # any of them. our $MODEL; # In BEGIN because the sandbox is built in one, before file scope runs. BEGIN { $MODEL = $ENV{TCMS_TEST_DATA_MODEL} || 'FlatFile' } # name => (size, mtime) for every file under the repo dirs this test could # plausibly disturb. Cheap enough, and it is the only real proof of isolation. sub _snapshot { my ($dir) = @_; my %seen; File::Find::find( { no_chdir => 1, wanted => sub { return unless -f $File::Find::name; my @st = stat(_); $seen{$File::Find::name} = "$st[7]:$st[9]"; }, }, $dir ); return %seen; } sub _copy_tree { my ( $from, $to ) = @_; File::Path::make_path($to); File::Find::find( { no_chdir => 1, wanted => sub { my $rel = substr( $File::Find::name, length($from) ); return unless length $rel; my $dst = "$to$rel"; if ( -d $File::Find::name ) { File::Path::make_path($dst) } elsif ( -f $File::Find::name ) { File::Copy::copy( $File::Find::name, $dst ) or die "copy $File::Find::name: $!" } }, }, $from ); return; } # Everything the sandbox needs, in one BEGIN. The Trog:: modules are require()d # at runtime below, which is unconditionally after every BEGIN -- so no later # edit can accidentally load them before the chdir. That matters: TCMS.pm runs # build_routes() at file scope and FlatFile.pm reads the tag index at file # scope, both against whatever cwd happens to be current. BEGIN { $REPO = Cwd::abs_path("$FindBin::Bin/.."); $OLDCWD = Cwd::getcwd(); %REPO_BEFORE = map { _snapshot("$REPO/$_") } qw{config data www/templates www/assets logs totp}; $ROOT = File::Temp::tempdir( 'tcms-lifecycle-XXXXXX', TMPDIR => 1, CLEANUP => 0 ); # Installer.mk's tree, plus upload-src for the file.tx fixture. File::Path::make_path( map { "$ROOT/$_" } qw{ config schema data/files logs totp upload-src www/assets/private www/statics www/themes www/scripts } ); # A real fresh install: get() looks for config/main.cfg, doesn't find one, # and falls through to the shipped default. The data model is the shipped # one unless the environment names another, which is how this whole file # gets run against each of them -- the point being that a data model is only # finished when the app cannot tell which one it is talking to. my $stock = File::Slurper::read_text("$REPO/config/default.cfg"); $stock =~ s/^(\s*data_model=).*$/$1$MODEL/m or die "could not set the data model in default.cfg"; File::Slurper::write_text( "$ROOT/config/default.cfg", $stock ); # Hardcoded paths in Auth.pm, TagIndex.pm, the data models and Log.pm -- not negotiable. File::Copy::copy( "$REPO/schema/$_", "$ROOT/schema/$_" ) or die $! for qw{auth.schema flatfile.schema sqlite.schema log.schema}; # COPY, don't symlink: post_wizard_save() writes into Trog::Themes::forms_dir(), # and a symlink would land the generated post type in the real repo. _copy_tree( "$REPO/www/templates", "$ROOT/www/templates" ); # posts.tx pulls in the EmojiPicker component for an editor, and EmojiPicker # dies outright if this file is missing. Only category and emoji are read. open( my $fh, '>', "$ROOT/www/scripts/list.min.json" ) or die $!; print {$fh} '{"emojis":[{"category":"Smileys","emoji":"X"}]}'; close $fh; # Text::Xslate computes its default cache dir from $HOME once, at load time. # Without this the sandbox writes compiled templates into the real ~/.xslate_cache. $ENV{HOME} = $ROOT; chdir($ROOT) or die "could not chdir to sandbox $ROOT: $!"; } END { # Never rmtree the directory you are standing in. chdir($OLDCWD) if $OLDCWD; if ( $ENV{TCMS_TEST_KEEP} ) { diag("TCMS_TEST_KEEP set, sandbox left at $ROOT"); } elsif ( $ROOT && -d $ROOT ) { # SQLite handles are file-lexical in Trog::SQLite and unreachable from # here; DBI disconnects at global destruction, after these are gone. eval { File::Path::remove_tree($ROOT) }; } } diag("sandbox: $ROOT"); require Trog::Log; Trog::Log::log_init( 'logs/tcms.log', 'info' ); # sets $LOGDIR, hence logs/log.db require Trog::Config; require Trog::Themes; require Trog::Data; require Trog::Auth; require Trog::SQLite::TagIndex if $MODEL eq 'FlatFile'; require Trog::Routes::HTML; require Trog::Routes::JSON; #-------------------------------------------------------------------------- # A stand-in for the tPSGI object the router injects as $query->{tpsgi}. #-------------------------------------------------------------------------- { package Test::TPSGI; sub new { my ( $class, %args ) = @_; return bless { callbacks => 0, run_callbacks => 0, renders => {}, invalidated => [], watches => [], restarts => 0, tpsgi_dir => Cwd::getcwd(), log_dir => 'logs', gid => $), verbose => 0, %args, }, $class; } sub INFO { 1 } sub DEBUG { 1 } sub WARN { 1 } sub ERROR { 1 } sub CRIT { 1 } sub ALERT { 1 } sub EMERG { 1 } sub FATAL { 1 } sub see_also { return [ 303, [ 'Location' => $_[1], 'Content-Length' => 0 ], [''] ] } sub redirect { return [ 302, [ 'Location' => $_[1], 'Content-Length' => 0 ], [''] ] } sub redirect_permanent { return [ 301, [ 'Location' => $_[1], 'Content-Length' => 0 ], [''] ] } sub _reply { return [ $_[1], [ 'Content-type' => 'text/html' ], [ defined $_[2] ? $_[2] : '' ] ] } sub ok { return $_[0]->_reply( 200, $_[2] ) } sub notfound { return $_[0]->_reply( 404, $_[2] // 'Not Found' ) } sub forbidden { return $_[0]->_reply( 403, $_[2] // 'Forbidden' ) } sub badrequest { return $_[0]->_reply( 400, $_[2] // 'Bad Request' ) } sub error { return $_[0]->_reply( 500, $_[2] // 'Error' ) } sub serve { return [ 200, [], [''] ] } # These two must be inert. # # add_post_close_callback is the ONLY path by which Trog::Renderer and # post_save reach save_render()/invalidate_renders(). Dropping the callback # on the floor is what guarantees this test never writes into www/statics, # whatever the renderer's own skip-save logic decides. # ...unless a test explicitly asks, which is how the one test that is about # what gets cached gets to see it. Still nowhere near www/statics: # save_render below only records what it was handed. sub add_post_close_callback { my ( $self, $callback ) = @_; $self->{callbacks}++; $callback->() if $self->{run_callbacks} && ref $callback eq 'CODE'; return 1; } # The real one is `kill 'HUP', getppid`. Under prove, that is prove. sub signal_restart_parent { $_[0]{restarts}++; return 1 } # Recorded rather than inert: a datasource that watches something is # supposed to register here, and the lifecycle test is where we find out # whether it did through the real route. sub add_watch { my ( $self, $path, $callback, %options ) = @_; push( @{ $self->{watches} }, { path => $path, callback => $callback, %options } ); return 1; } sub invalidate_renders { push @{ $_[0]{invalidated} }, $_[1]; return 1 } sub invalidate_render { push @{ $_[0]{invalidated} }, [ @_[ 1 .. $#_ ] ]; return 1 } sub save_render { $_[0]{renders}{"$_[1]:$_[2]"} = $_[3]; return 1 } } our $TPSGI = Test::TPSGI->new(); our $ADMIN_USER = 'specadmin'; our $ADMIN_DISPLAY = 'Spec Admin'; our $ADMIN_EMAIL = 'specadmin@example.com'; our $ADMIN_PASS = 'spec-password'; #-------------------------------------------------------------------------- # Harness #-------------------------------------------------------------------------- # Always build a fresh query: posts() pushes onto user_acls, and series() # rewrites route/aclname/tag/in_series/primary_post in place. sub _query { my (%over) = @_; my %q = ( route => '/', method => 'GET', scheme => 'http', # Renderer::Base compares this with no undef guard domain => 'tcms.test', start => [ Time::HiRes::gettimeofday() ], # tv_interval() dies on anything else deflate => 0, streaming => 0, ranges => [], last_fetched => undef, has_query => 0, social_meta => 0, acls => [], user_acls => [], body => undef, tpsgi => $TPSGI, %over, ); $q{fullpath} //= $q{route}; return \%q; } sub _anon { return _query( user => undef, user_acls => [], @_ ) } sub _admin { return _query( user => $ADMIN_USER, user_acls => ['admin'], @_ ) } # Returns ($code, $body, $error). Never dies, so one bad post type cannot take # the rest of the file with it -- which matters because a failed render inside # index() dies rather than returning a 500 (there is no www/templates/html/500.tx). sub _render { my ( $query, $how ) = @_; $how ||= \&Trog::Routes::HTML::index; my $res = eval { $how->($query) }; return ( 0, '', "died: $@" ) if !$res; return ( 0, '', 'returned a ' . ( ref($res) || 'plain scalar' ) ) if ref $res ne 'ARRAY'; my ( $code, $headers, $body ) = @$res; $body = ref $body eq 'ARRAY' ? join( '', @$body ) : ( $body // '' ); return ( $code, Encode::decode_utf8($body), '', $headers ); } # FlatFile snapshots the tag list at load time and then filters each query's # tags against it IN PLACE -- so a tag created later isn't merely unindexed, it # is deleted from the query, and the filter silently degrades to "every public # post". Production gets away with it because a save HUPs the parent and the # worker re-execs. We have to do it by hand. # # Nothing to do for a model that asks the database each time, which is the # point: this helper exists to paper over a cache, and a model without one # needs no paper. sub _reindex { return unless $MODEL eq 'FlatFile'; no warnings 'once'; @Trog::Data::FlatFile::tags = Trog::SQLite::TagIndex::tags(); %Trog::Data::FlatFile::posts_by_tag = (); return; } sub _data { return Trog::Data->new( Trog::Config::get() ) } # categories.tx renders into . Scope to it -- index.tx # emits other class="topbar" anchors outside that span. sub _topbar_titles { my ($body) = @_; my ($span) = $body =~ m{(.*?)}s; return () unless defined $span; return $span =~ m{class="topbar">([^<]*)}g; } # post_title.tx emits exactly one of these per displayed post. sub _post_count { my $n = () = $_[0] =~ m{

}g; return $n; } # The rendered page is ~40KB and mostly JavaScript. Show the content well. sub _kontent { my ($body) = @_; my ($k) = $body =~ m{
(.*?)
//gs; return length($k) > 2500 ? substr( $k, 0, 2500 ) . "\n...[truncated]" : $k; } # Save through post_save() rather than $data->add(): add() dies with an # arrayref of validator errors, whereas post_save catches them and hands back a # 400 with the field-level detail in the body -- which is the single most # useful thing to see when a fixture is wrong. sub _save_post { my ( $label, %post ) = @_; my $to = delete $post{to}; my $res = eval { Trog::Routes::HTML::post_save( _admin( route => '/post/save', method => 'POST', to => $to, %post ) ) }; if ( !$res || ref $res ne 'ARRAY' ) { fail("$label: saved"); diag( $@ || 'post_save returned nothing' ); return undef; } my ( $code, $headers, $body ) = @$res; my %h = @{ $headers || [] }; # Both outcomes redirect now, so the status alone proves nothing -- the # outcome is in the query string post_save hands to the destination. if ( $code != 303 || ( $h{Location} // '' ) =~ m/savefailed=/ ) { fail("$label: saved"); diag( "post_save returned $code, Location: " . ( $h{Location} // '(none)' ) ); diag( join( '', @{ $body || [''] } ) ) if $body && @$body; return undef; } pass("$label: saved"); _reindex(); # mandatory: see the comment on _reindex my $saved = _find_post( $post{title} ); ok( $saved, "$label: readable back out of the datastore" ) or return undef; return $saved; } sub _find_post { my ($title) = @_; # filter() short-circuits on title; the admin acl skips the visibility filter. my @posts = _data()->get( title => $title, acls => ['admin'], limit => 0 ); return $posts[0]; } #-------------------------------------------------------------------------- subtest 'the sandbox is what we are actually running against' => sub { is( Cwd::getcwd(), Cwd::abs_path($ROOT), 'cwd is the sandbox' ); ok( -d 'data/files', 'datastore dir exists' ); ok( -f 'config/default.cfg', 'config was seeded' ); ok( !-f 'config/main.cfg', 'and there is no main.cfg, so we fall through to the default' ); my $conf = Trog::Config::get(); is( $conf->param('general.data_model'), $MODEL, 'config resolves inside the sandbox' ); like( Trog::Themes::forms_dir(), qr/^www\/templates/, 'forms dir is relative, hence sandboxed' ); ok( -d Cwd::abs_path( Trog::Themes::forms_dir() ), 'and it exists' ); like( Cwd::abs_path( Trog::Themes::forms_dir() ), qr/^\Q$ROOT\E/, 'and it is under the sandbox, not the repo' ); }; subtest 'registering the first admin bootstraps the install' => sub { ok( !-f 'config/has_users', 'no users yet, so login() is in register mode' ); my ( $code, $body, $err, $headers ) = _render( _anon( route => '/login', method => 'POST', username => $ADMIN_USER, display_name => $ADMIN_DISPLAY, contact_email => $ADMIN_EMAIL, password => $ADMIN_PASS, to => '/', ), \&Trog::Routes::HTML::login, ); is( $code, 200, 'login() rendered' ) or diag($err); my %h = @{ $headers || [] }; like( $h{'Set-Cookie'} // '', qr/^tcmslogin=[0-9a-f-]{36};/, 'a session cookie came back' ); ok( -f 'config/has_users', 'registration is now closed' ); is_deeply( Trog::Auth::acls4user($ADMIN_USER), ['admin'], 'the new user is an admin' ); _reindex(); my @seeded = _data()->get( acls => ['admin'], limit => 0 ); is( scalar @seeded, 4, 'the four seed posts were written' ) or diag( 'got: ' . join( ', ', map { "$_->{title} ($_->{form})" } @seeded ) ); }; subtest 'the post wizard invents a new post type' => sub { my %wizard = ( name => 'spec_widget', title_placeholder => 'Widget Name', body_form => 'form_common.tx', wrapper => 1, inc_post_title => 1, inc_post_tags => 1, inc_title_input => 1, inc_visibility => 1, inc_tags => 1, inc_aliases => 1, param_name => ['flavor'], param_type => ['text'], param_label => ['Flavor'], param_placeholder => ['Strawberry'], param_required => [0], display => q{
} . q{<: $post.flavor :>} . q{<: render_it($post.data) | mark_raw :>
}, ); my ( $code, $body, $err ) = _render( _admin( route => '/admin/wyzzerdd/save', method => 'POST', %wizard ), \&Trog::Routes::HTML::post_wizard_save, ); is( $code, 200, 'wizard save rendered' ) or diag($err); ok( -f 'www/templates/html/components/forms/spec_widget.tx', 'the template was written' ); ok( -f 'www/templates/html/components/forms/spec_widget.json', 'the schema sidecar was written' ); # The existing types are a dropdown now, not a list. like( $body, qr{