From: Matt S Trout Date: Tue, 31 Jul 2012 18:34:09 +0000 (+0000) Subject: initial import of App::SCS code X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=632f0e076b6f254788a987b6c43b8ad0093715f3;p=scpubgit%2FApp-SCS.git initial import of App::SCS code --- diff --git a/lib/App/SCS.pm b/lib/App/SCS.pm new file mode 100644 index 0000000..c8a3c07 --- /dev/null +++ b/lib/App/SCS.pm @@ -0,0 +1,57 @@ +package App::SCS; + +use Module::Runtime qw(use_module); +use IO::All; +use Moo; + +with 'App::SCS::Role::WithConfig'; + +has plugins => (is => 'ro', default => sub { [] }); + +has pages => (is => 'lazy'); + +sub _build_pages { + my ($self) = @_; + return use_module('App::SCS::PageSet')->new( + base_dir => io->dir($self->config->{share_dir})->catdir('pages'), + plugin_config => { + plugin_map => { + map $_->page_plugins, reverse @{$self->plugins} + }, + defaults => [ + map $_->default_page_plugins, @{$self->plugins} + ], + } + ); +} + +has web => (is => 'lazy'); + +sub _build_web { + my ($self) = @_; + return use_module('App::SCS::Web')->new( + app => $self + ); +} + +sub BUILD { + my ($self) = @_; + $self->load_plugin(Core => {}); + foreach my $spec (@{$self->config->{plugins}||[]}) { + $self->load_plugin(@$spec); + } +} + +sub load_plugin { + my ($self, $name, $config) = @_; + push( + @{$self->plugins}, + use_module("App::SCS::Plugin::${name}")->new( + app => $self, + config => $config + ) + ); + return; +} + +1; diff --git a/lib/App/SCS/Page.pm b/lib/App/SCS/Page.pm new file mode 100644 index 0000000..e6f78a4 --- /dev/null +++ b/lib/App/SCS/Page.pm @@ -0,0 +1,119 @@ +package App::SCS::Page; + +use IO::All; +use Time::Local qw(timelocal); +use Data::Pond qw(pond_read_datum pond_write_datum); +use List::Util qw(reduce); +use Moo; + +with 'App::SCS::Role::PageChildren'; + +has $_ => (is => 'ro') for qw( + title subtitle description keywords plugins html created path +); + +has plugin_config => (is => 'lazy'); + +sub _build_plugin_config { + my ($self) = @_; + $self->plugins + ? pond_read_datum('[ '.$self->plugins.' ]') + : [] +} + +sub has_plugin_config { exists $_[0]->plugin_config->{$_[1]} } + +sub with_plugin_config { + my ($self, $with_name, $with_config) = @_; + my @orig = @{$self->plugin_config}; + my @new; + while (my ($name, $config) = splice @orig, 0, 2) { + push @new, ( + $name eq $with_name + ? ($name, { %$config, %$with_config }) + : ($name, $config) + ); + } + return $self->with(plugins => pond_write_datum(\@new)); +} + +has _page_plugins => (is => 'lazy'); + +sub _build__page_plugins { + my ($self) = @_; + my $plugin_config = $self->plugin_config; + my ($plugin_map, $defaults) = @{$self->_page_set}{qw(plugin_map defaults)}; + + my @spec = (@$defaults, @$plugin_config); + my @plugins; + while (my ($name, $config) = splice @spec, 0, 2) { + my $info = $plugin_map->{$name}; + push @plugins, + use_module($info->{class})->new( + %{$info->{config}||{}}, %$config, page => $self + ); + } + return \@plugins; +} + +sub published_at { + $_[0]->created + ? scalar localtime timelocal + map +(@{$_}[0..3], $_->[4]-1, $_->[5]-1900), + [ reverse split '\D+', $_[0]->created ] + : '' +} + +has "_$_" => (is => 'ro', init_arg => $_) for qw(page_set); + +sub _page_set_class { ref($_[0]->_page_set) } +sub _top_dir { $_[0]->_page_set->top_dir } +sub _my_path { io->dir($_[0]->_top_dir)->catdir($_[0]->path) } + +sub to_app { + my ($self) = @_; + return sub { $self->to_psgi_response(@_) }; +} + +sub to_psgi_response { + my ($self, $env) = @_; + + if (my $cb = $env->{'App::SCS::Command::Generate.extra_pages'}) { + $cb->($_->extra_pages) for @{$self->page_plugins}; + } + + $self->_psgi_response; +} + +has _psgi_response => (is => 'lazy'); + +sub _build__psgi_response { + my ($self) = @_; + + my @plugins = @{$self->page_plugins}; + + my $html_zoom = reduce { + $b->filter_html_zoom($a) + } HTML::Zoom->from_html($self->html), @plugins; + + my $content_zoom = reduce { + $b->filter_content_zoom($a) + } $html_zoom, @plugins; + + my $psgi_res = [ + 200, [ 'Content-type' => 'text/html' ], $content_zoom->to_fh + ]; + + return reduce { + $b->filter_psgi_response($a) + } $psgi_res, @plugins; +} + +no Moo; + +sub with { + my $self = shift; + return ref($self)->new(%$self, @_); +} + +1; diff --git a/lib/App/SCS/PageSet.pm b/lib/App/SCS/PageSet.pm new file mode 100644 index 0000000..b71c5d4 --- /dev/null +++ b/lib/App/SCS/PageSet.pm @@ -0,0 +1,172 @@ +package App::SCS::PageSet; + +use Text::MultiMarkdown 'markdown'; +use HTML::Zoom; +use Sub::Quote; +use Syntax::Keyword::Gather; +use App::SCS::Page; +use IO::All; +use Try::Tiny; +use List::Util qw(reduce); +use JSON; +use Moo; + +with 'App::SCS::Role::PageChildren'; + +{ + my $j = JSON->new; + sub _json { $j } +} + +has top_dir => (is => 'ro', lazy => 1, builder => 'base_dir'); +has base_dir => (is => 'ro', required => 1); +has plugin_config => (is => 'ro', required => 1); +has max_depth => (is => 'ro', default => quote_sub q{ 0 }); +has min_depth => (is => 'ro', default => quote_sub q{ 1 }); + +has rel_path => (is => 'lazy'); + +sub _build_rel_path { + my ($self) = @_; + io->dir('/') + ->catdir(File::Spec->abs2rel($self->base_dir->name, $self->top_dir->name)) +} + +sub _page_set_class { ref($_[0]) } +sub _top_dir { shift->top_dir } +sub _my_path { shift->base_dir } + +sub get { + my ($self, $spec) = @_; + $spec->{path} or die "path is required to get"; + my ($dir, $file) = $spec->{path} =~ m{^(?:(.*)/)?([^/]+)$}; + my $type; + my @poss = io->dir($self->base_dir)->${\sub { + my $io = shift; + defined($dir) ? $io->catdir($dir) : $io + }}->filter(sub { + $_->filename =~ /^\Q${file}\E${\$self->_types_re}$/ and $type = $1 + }) + ->${\sub { -e "$_[0]" ? $_[0]->all_files : () }}; + die "multiple files found for ${\$spec->{path}}:\n".join "\n", @poss + if @poss > 1; + return undef unless @poss; + $self->_inflate( + $type, $self->rel_path->catdir($spec->{path}), $poss[0] + ); +} + +sub _inflate { + my ($self, $type, $path, $io) = @_; + (my $cache_name = $io->name) =~ s/\/([^\/]+)$/\/.htcache.$1.json/; + my $cache = io($cache_name); + if (-f $cache_name) { + if ($cache->mtime >= $io->mtime) { + return try { + $self->_new_page($path, $self->_json->decode($cache->all)); + } catch { + die "Error inflating ${path} from cache: $_\n"; + } + } + } + my $raw = $io->all; + try { + my $extracted = $self->${\"_extract_from_${type}"}($raw); + try { $cache->print($self->_json->encode($extracted)); }; + $self->_new_page($path, $extracted); + } catch { + die "Error inflating ${path} as ${type}: $_\n"; + } +} + +sub map { + my ($self, $mapper) = @_; + [ map $mapper->($_), $self->flatten ] +} + +sub _depth_under_base { + my ($self, $path) = @_; + File::Spec->splitdir(File::Spec->abs2rel($path, $self->base_dir->name)) +} + +sub flatten { + my ($self) = @_; + my $slash = io->dir('/'); + map { + my ($path, $type) = $_->name =~ /^(.*)${\$self->_types_re}$/; + $self->_inflate( + $type, + $slash->catdir(File::Spec->abs2rel($path, $self->top_dir->name)), + $_ + ); + } $self->_all_files; +} + +sub all_paths { + my ($self) = @_; + my $slash = io->dir('/'); + map { + my ($path, $type) = $_->name =~ /^(.*)${\$self->_types_re}$/; + $slash->catdir(File::Spec->abs2rel($path, $self->top_dir->name))->name, + } $self->_all_files; +} + +sub _all_files { + my ($self) = @_; + return unless (my $base = $self->base_dir)->exists; + my %seen; + my $min = $self->min_depth; + map { + $_->filter(sub { $_->filename =~ /${\$self->_types_re}$/ }) + ->all_files($self->max_depth - ($min-1)) + } map + $min > 1 + ? do { + # can't use ->all_dirs($min-1) since we only want the final level + my @x = ($_); @x = map $_->all_dirs, @x for 1..$min-1; @x + } + : $_, + $base; +} + +sub latest { + my ($self, $max) = @_; + require SCSite::LatestPageSet; + SCSite::LatestPageSet->new( + parent => $self, + max_entries => $max, + ); +} + +sub _new_page { + SCSite::Page->new({ path => $_[1], page_set => $_[0], %{$_[2]} }) +} + +sub _types_re { qw/\.(html|md)/ } + +sub _extract_from_html { + my ($self, $html) = @_; + my %meta; + HTML::Zoom->from_html($html) + ->select('title')->collect_content({ into => \my @title }) + ->${\sub { + my $z = shift; + return reduce { + $a->collect("meta[name=${b}]", { into => ($meta{$b}=[]) }) + } $z, qw(subtitle description keywords created plugins) + }} + ->run; + +{ + title => $title[0]->{raw}||'', + (map +($_ => $meta{$_}[0]->{attrs}{content}||''), keys %meta), + html => $html, + } +} + +sub _extract_from_md { + my ($self, $md) = @_; + #warn markdown($md, { document_format => 'complete' }); + $self->_extract_from_html(markdown($md, { document_format => 'complete' })); +} + +1; diff --git a/lib/App/SCS/Plugin/Archives.pm b/lib/App/SCS/Plugin/Archives.pm new file mode 100644 index 0000000..d42ce6c --- /dev/null +++ b/lib/App/SCS/Plugin/Archives.pm @@ -0,0 +1,26 @@ +package App::SCS::Plugin::Archives; + +use Moo; +no warnings::illegalproto; + +with 'App::SCS::Role::Plugin'; + +sub page_plugins { + Archive => 'App::SCS::Plugin::Archive::PagePlugin' +} + +sub page_dispatchers { + my ($self) = @_; + sub (/**:path/old/:page) { + return unless $_{page} =~ /^\d+$/; + if (my $page = $self->pages->get({ path => $_{path} })) { + if ($page->has_plugin_config('Archive')) { + return $page->with(path => $_{path}) + ->with_plugin_config(Archive => { page => $_{page} }); + } + } + return; + } +} + +1; diff --git a/lib/App/SCS/Plugin/Core.pm b/lib/App/SCS/Plugin/Core.pm new file mode 100644 index 0000000..f799f70 --- /dev/null +++ b/lib/App/SCS/Plugin/Core.pm @@ -0,0 +1,66 @@ +package App::SCS::Plugin::Core; + +use Moo; +no warnings::illegalproto; +use Safe::Isa; + +with 'App::SCS::Role::Plugin'; + +has templates => (is => 'lazy'); + +sub _build_templates { + my ($self) = @_; + return use_module('App::SCS::PageSet')->new( + base_dir => io->dir($self->app->config->{share_dir})->catdir('templates'), + ); +} + +has includes => (is => 'lazy'); + +sub _build_includes { + my ($self) = @_; + return use_module('App::SCS::PageSet')->new( + base_dir => io->dir($self->app->config->{share_dir})->catdir('includes'), + ); +} + +sub page_plugins { + my ($self) = @_; + PageList => 'App::SCS::Plugin::Core::PagePlugin::PageList', + Template => { + class => 'App::SCS::Plugin::Core::PagePlugin::Template', + config => { templates => $self->templates }, + }, + Include => { + class => 'App::SCS::Plugin::Core::PagePlugin::Include', + config => { includes => $self->includes }, + }, + PageData => 'App::SCS::Plugin::Core::PagePlugin::PageData', +} + +sub default_page_plugins { + Template => { + name => 'layout', + }, + PageData => {}, +} + +sub page_dispatchers { + my ($self) = @_; + sub (/) { + $self->pages->get({ path => 'index' }); + }, + sub (/**) { + [ 302, [ 'Location' => "/$_[1]/" ], [] ] + }, + sub (/**:path/) { + $self->pages->get({ %_ }) + }, + sub () { + $self->pages + ->get({ path => 'error_404' }) + ->$_call_if_object(with_plugin_config => Status => 404); + }, +} + +1; diff --git a/lib/App/SCS/Plugin/Core/PagePlugin/PageData.pm b/lib/App/SCS/Plugin/Core/PagePlugin/PageData.pm new file mode 100644 index 0000000..daf529f --- /dev/null +++ b/lib/App/SCS/Plugin/Core/PagePlugin/PageData.pm @@ -0,0 +1,25 @@ +package App::SCS::Plugin::Core::PagePlugin::PageData; + +use Moo; + +with 'App::SCS::Role::PagePlugin'; + +sub filter_content_zoom { + my ($self, $zoom) = @_; + my $page = $self->page; + $zoom->select('.page.title')->replace_content($page->title) + ->select('.page.subtitle')->${\sub { + $page->subtitle + ? $_[0]->replace_content($page->subtitle) + : $_[0]->replace('') + }} + ->select('.page.published_at')->replace_content($page->published_at) + ->select('meta[name=description]') + ->set_attribute(content => $page->description) + ->select('meta[name=keywords]') + ->set_attribute(content => $page->keywords) + ->select('meta[name=created]') + ->set_attribute(content => $page->created); +} + +1; diff --git a/lib/App/SCS/Plugin/Core/PagePlugin/Template.pm b/lib/App/SCS/Plugin/Core/PagePlugin/Template.pm new file mode 100644 index 0000000..b1e47ce --- /dev/null +++ b/lib/App/SCS/Plugin/Core/PagePlugin/Template.pm @@ -0,0 +1,26 @@ +package App::SCS::Plugin::Core::PagePlugin::Template; + +use Moo; + +with 'App::SCS::Role::PagePlugin'; + +has templates => (is => 'ro', required => 1); + +has name => (is => 'ro', required => 1); + +sub filter_html_zoom { + my ($self, $zoom) = @_; + my $template_page = $self->templates->get({ path => $self->name }) + or die "No such template ${\$self->name}"; + my $template_zoom = HTML::Zoom->from_html($template_page->html); + my @ev; + $template_zoom->collect('*[data-replace]', { into => \@ev }) + ->then + ->${\sub { + my $sel = $ev[0]->{attrs}{'data-replace'}; + $zoom->collect($self, { into => \my @replace })->run; + shift->replace(\@replace); + }} +} + +1; diff --git a/lib/App/SCS/Plugin/Feeds.pm b/lib/App/SCS/Plugin/Feeds.pm new file mode 100644 index 0000000..abd8dcd --- /dev/null +++ b/lib/App/SCS/Plugin/Feeds.pm @@ -0,0 +1,39 @@ +package App::SCS::Plugin::Feeds; + +use Module::Runtime qw(use_module); +use Moo; + +with 'App::SCS::Role::Plugin'; + +has mount_at => (is => 'ro', default => sub { 'feed' }); + +has generator => ( + is => 'lazy', + handles => { _feed_http_response => 'feed_http_response' }, +); + +sub _build_generator { + my ($self) = @_; + use_module('App::SCS::Plugin::Feeds::Generator')->new( + pages => $self->pages, + mounted_at => $self->mount_at, + ); +} + +sub page_dispatchers { + my ($self) = @_; + my $base = $self->mount_at; + "/${base}/**/" => sub { + if (my $conf = $self->config->{$_[1]}) { + $self->_feed_http_response(200 => $conf => $_[-1]); + } + }, +} + +sub provides_pages { + my ($self) = @_; + my $base = $self->mount_at; + return map "/${base}/$_/", keys %{$self->config}; +} + +1; diff --git a/lib/App/SCS/Plugin/Feeds/Generator.pm b/lib/App/SCS/Plugin/Feeds/Generator.pm new file mode 100644 index 0000000..f2fdb21 --- /dev/null +++ b/lib/App/SCS/Plugin/Feeds/Generator.pm @@ -0,0 +1,124 @@ +package App::SCS::Plugin::Feeds::Generator; + +use URI; +use Moo; +no warnings 'once'; + +has pages => (is => 'ro', required => 1); + +has mounted_at => (is => 'ro', required => 1); + +sub feed_http_response { + my ($self, $code, $feed_config, $env) = @_; + $self->_feed_response( + $code, $self->_config_to_data($feed_config, $env) + ); +} + +sub _config_to_data { + my ($self, $config, $env) = @_; + my $url_scheme = $env->{'psgi.url_scheme'} || "http"; + my $url_port = $env->{SERVER_PORT}||80; + my $base_url = URI->new( + $url_scheme + .'://' + .($env->{HTTP_HOST} + or ( + ($env->{SERVER_NAME} || "") + .($url_scheme eq 'http' && $url_port == 80 + ? '' + : ":${url_port}" + ) + )) + .($env->{SCRIPT_NAME} || '/') + ); + my $abs = sub { URI->new_abs($_[0], $base_url)->as_string }; + my $base_page = $self->pages->get({ path => $config->{base} }); + my @entry_pages = $base_page->children(%{$config->{entries}}) + ->latest(10)->flatten; + my $updated = (sort map $_->created, @entry_pages)[-1]; + my $base = $self->mounted_at; + +{ + %$config, + id => $abs->("${base}/${\$config->{base}}/"), + web_url => $abs->($config->{base}.'/'), + feed_url => $abs->("${base}/${\$config->{base}}/"), + updated => join('T', split(' ',$updated)).'Z', + entries => [ map { + my $page_url = $abs->(do { (my $p = $_->path) =~ s/^\///; "$p/" }); + +{ + title => $_->title, + summary_html => do { + use HTML::Tags; + join '', HTML::Tags::to_html_string(

, $_->description,

) + }, + content_html => $self->_absolutify_html($_->body, $base_url, $page_url), + created => join('T', split(' ',$_->created)).'Z', + web_url => $page_url, + } + } @entry_pages ], + } +} + +sub _feed_response { + my ($self, $code, $data) = @_; + [ $code, + [ 'Content-type' => 'application/atom+xml' ], + [ $self->_feed_string($data) ] + ] +} + +sub _feed_string { + my ($self, $data) = @_; + XML::Tags::to_xml_string( + $self->_feed_data_to_tags($data) + ); +} + +sub _feed_data_to_tags { + my ($self, $data) = @_; + use XML::Tags qw( + feed title subtitle link id + ); + my ($web_url, $feed_url) = @{$data}{qw(web_url feed_url)}; + (\'', "\n", + , "\n", + ' ', , $data->{title}, , "\n", + ($data->{subtitle} + ? (' ', , $data->{subtitle}, , "\n",) + : ()), + ' ', , "\n", + ' ', , "\n", + ' ', , $data->{updated}, , "\n", + ' ', , $data->{id}, , "\n", + (map $self->_entry_data_to_tags($_), @{$data->{entries}}), + ); +} + +sub _entry_data_to_tags { + my ($self, $data) = @_; + use XML::Tags qw( + entry title author name link id published updated summary content + ); + my $web_url = $data->{web_url}; + ' ', , "\n", + ' ', , $data->{title}, , "\n", + ' ', , , "Shadowcat Staff", , , "\n", + ' ', , "\n", + ' ', , $web_url, , "\n", + ' ', , $data->{created}, , "\n", + ' ', , ($data->{created}||$data->{updated}), , "\n", + ($data->{summary_html} + ? (' ', , \('{summary_html}.']]>'), , "\n") + : () + ), + ' ', , \('{content_html}.']]>'), , "\n", + ' ', , "\n"; +} + +sub _absolutify_html { + my ($self, $html, $base_url, $page_url) = @_; + $html; +} + +1; diff --git a/lib/App/SCS/Role/PageChildren.pm b/lib/App/SCS/Role/PageChildren.pm new file mode 100644 index 0000000..3e6f2f3 --- /dev/null +++ b/lib/App/SCS/Role/PageChildren.pm @@ -0,0 +1,22 @@ +package App::SCS::Role::PageChildren; + +use Moo::Role; + +requires '_page_set_class'; +requires '_top_dir'; +requires '_my_path'; + +sub children { + my ($self, %args) = @_; + if (my $at = delete $args{at_depth}) { + @args{qw(min_depth max_depth)} = ($at, $at); + } + $self->_page_set_class->new( + top_dir => $self->_top_dir, + base_dir => $self->_my_path, + max_depth => 1, + %args, + ); +} + +1; diff --git a/lib/App/SCS/Role/PagePlugin.pm b/lib/App/SCS/Role/PagePlugin.pm new file mode 100644 index 0000000..f7b1055 --- /dev/null +++ b/lib/App/SCS/Role/PagePlugin.pm @@ -0,0 +1,15 @@ +package App::SCS::Role::PagePlugin; + +use Moo::Role; + +has 'page' => (is => 'ro', weak_ref => 1, required => 1); + +sub extra_pages { () } + +sub filter_html_zoom { shift } + +sub filter_content_zoom { shift } + +sub filter_psgi_response { shift } + +1; diff --git a/lib/App/SCS/Role/Plugin.pm b/lib/App/SCS/Role/Plugin.pm new file mode 100644 index 0000000..c134fc3 --- /dev/null +++ b/lib/App/SCS/Role/Plugin.pm @@ -0,0 +1,22 @@ +package App::SCS::Role::Plugin; + +use Moo::Role; + +with 'App::SCS::Role::WithConfig'; + +has app => ( + is => 'ro', weak_ref => 1, required => 1, + handles => [ 'pages' ], +); + +sub page_plugins { () } + +sub default_page_plugins { () } + +sub page_dispatchers { () } + +sub provides_pages { () } + +sub register { return } + +1; diff --git a/lib/App/SCS/Role/WithConfig.pm b/lib/App/SCS/Role/WithConfig.pm new file mode 100644 index 0000000..8eed0ca --- /dev/null +++ b/lib/App/SCS/Role/WithConfig.pm @@ -0,0 +1,22 @@ +package App::SCS::Role::WithConfig; + +use Moo::Role; + +has 'config' => ( + is => 'ro', + default => sub { + my ($self) = @_; + +{ $self->default_config } + }, + trigger => sub { + my ($self, $value) = @_; + my %default = $self->default_config; + my @not = grep !exists $value->{$_}, keys %default; + @{$value}{@not} = @default{@not}; + } +); + +sub default_config { () } + + +1; diff --git a/lib/App/SCS/Web.pm b/lib/App/SCS/Web.pm new file mode 100644 index 0000000..4c5b451 --- /dev/null +++ b/lib/App/SCS/Web.pm @@ -0,0 +1,27 @@ +package App::SCS::Web; + +use Safe::Isa; +use Web::Simple; + +has app => (is => 'ro', weak_ref => 1, required => 1); + +has _page_dispatchers => (is => 'lazy'); + +sub _build__page_dispatchers { + my ($self) = @_; + [ map $_->page_dispatchers, reverse @{$self->app->plugins} ] +} + +has _page_dispatchers => (is => 'lazy'); + +sub _build__page_dispatchers { + my ($self) = @_; + [ map $_->page_dispatchers, reverse @{$self->app->plugins} ] +} + +sub dispatch_request { + my ($self) = @_; + return @{$self->_page_dispatchers}; +} + +1; diff --git a/t/01load.t b/t/01load.t new file mode 100644 index 0000000..cffc95c --- /dev/null +++ b/t/01load.t @@ -0,0 +1,15 @@ +use strictures 1; +use Test::More; +use Test::SharedFork; +use IO::All; + +foreach my $module (grep $_->name =~ /\.pm$/, io->dir('lib')->all_files(0)) { + unless (fork) { + ok(eval { require $module }, "${module} loaded ok"); + warn $@ if $@; + exit 0; + } + waitpid(-1, 0); +} + +done_testing;