summaryrefslogtreecommitdiff
path: root/lib/VNWeb
diff options
context:
space:
mode:
Diffstat (limited to 'lib/VNWeb')
-rw-r--r--lib/VNWeb/DB.pm51
-rw-r--r--lib/VNWeb/Docs/Edit.pm57
-rw-r--r--lib/VNWeb/Elm.pm236
-rw-r--r--lib/VNWeb/HTML.pm16
-rw-r--r--lib/VNWeb/Prelude.pm47
-rw-r--r--lib/VNWeb/Validation.pm66
6 files changed, 469 insertions, 4 deletions
diff --git a/lib/VNWeb/DB.pm b/lib/VNWeb/DB.pm
index b839baf3..7ef2e161 100644
--- a/lib/VNWeb/DB.pm
+++ b/lib/VNWeb/DB.pm
@@ -12,7 +12,7 @@ our @EXPORT = qw/
sql
sql_join sql_comma sql_and sql_array sql_func sql_fromhex sql_tohex sql_fromtime sql_totime
enrich enrich_merge enrich_flatten
- db_entry
+ db_entry db_edit
/;
@@ -222,6 +222,7 @@ my $entry_types = do {
# TODO:
# - Use non _hist tables if $maxrev == $rev (should be faster)
# - Combine the enrich_merge() calls into a single query.
+# - Fixed ordering of arrays (use primary keys)
sub db_entry {
my($type, $id, $rev) = @_;
my $t = $entry_types->{$type}||die;
@@ -261,4 +262,52 @@ sub db_entry {
$entry
}
+
+# Edit or create an entry, usage:
+# ($id, $chid, $rev) = db_edit $type, $id, $data, $uid;
+#
+# $id should be undef to create a new entry.
+# $uid should be undef to use the currently logged in user.
+# $data should have the same format as returned by db_entry(), but instead with
+# the following additional keys in the top-level hash:
+#
+# hidden, locked, editsum
+sub db_edit {
+ my($type, $id, $data, $uid) = @_;
+ $id ||= undef;
+ my $t = $entry_types->{$type}||die;
+
+ tuwf->dbExeci("SELECT edit_${type}_init(", \$id, ', (SELECT MAX(rev) FROM changes WHERE type = ', \$type, ' AND itemid = ', \$id, '))');
+ tuwf->dbExeci('UPDATE edit_revision SET', {
+ requester => $uid // scalar VNWeb::Auth::auth()->uid(),
+ ip => scalar tuwf->reqIP(),
+ comments => $data->{editsum},
+ ihid => $data->{hidden},
+ ilock => $data->{locked},
+ });
+
+ {
+ my $base = $t->{base}{name} =~ s/_hist$//r;
+ tuwf->dbExeci("UPDATE edit_${base} SET ", sql_comma(
+ map sql("\"$_->{name}\"", ' = ', \$data->{$_->{name}}),
+ grep exists $data->{$_->{name}}, $t->{base}{cols}->@*
+ ));
+ }
+
+ while(my($name, $tbl) = each $t->{tables}->%*) {
+ my $base = $tbl->{name} =~ s/_hist$//r;
+ my @cols = map sql_comma(map "\"$_->{name}\""), $tbl->{cols}->$@;
+ my @rows = map {
+ my $d = $_;
+ sql '(', sql_comma(map \$d, $tbl->{cols}->@*), ')'
+ } $data->{$name}->@*;
+
+ tuwf->dbExeci("DELETE FROM edit_${base}");
+ tuwf->dbExeci("INSERT INTO edit_${base} (", @cols, ') VALUES ', sql_comma @rows) if @rows;
+ }
+
+ my $r = tuwf->dbRow("SELECT * FROM edit_${type}_commit()");
+ ($r->{itemid}, $r->{chid}, $r->{rev})
+}
+
1;
diff --git a/lib/VNWeb/Docs/Edit.pm b/lib/VNWeb/Docs/Edit.pm
new file mode 100644
index 00000000..ad3af9ec
--- /dev/null
+++ b/lib/VNWeb/Docs/Edit.pm
@@ -0,0 +1,57 @@
+package VNWeb::Docs::Edit;
+
+use VNWeb::Prelude;
+use VNWeb::Docs::Lib;
+
+
+my $FORM = {
+ title => { maxlength => 200 },
+ content => { required => 0, default => '' },
+ hidden => { anybool => 1 },
+ locked => { anybool => 1 },
+
+ editsum => { _when => 'in out', editsum => 1 },
+ id => { _when => 'out', id => 1 },
+};
+
+my $FORM_OUT = form_compile out => $FORM;
+my $FORM_IN = form_compile in => $FORM;
+my $FORM_CMP = form_compile cmp => $FORM;
+
+elm_form DocEdit => $FORM_OUT, $FORM_IN;
+
+
+TUWF::get qr{/$RE{drev}/edit} => sub {
+ my $d = db_entry d => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound;
+ return tuwf->resDenied if !can_edit d => $d;
+
+ $d->{editsum} = $d->{chrev} == $d->{maxrev} ? '' : "Reverted to revision d$d->{id}.$d->{chrev}";
+
+ framework_ title => "Edit $d->{title}", index => 0, type => 'd', dbobj => $d, tab => 'edit',
+ sub {
+ elm_ DocEdit => $FORM_OUT, $d;
+ };
+};
+
+
+json_api qr{/$RE{drev}/edit}, $FORM_IN, sub {
+ my $data = shift;
+ my $doc = db_entry d => tuwf->capture('id') or return tuwf->resNotFound;
+
+ return elm_Unauth if !can_edit d => $doc;
+ return elm_Unchanged if !form_changed $FORM_CMP, $data, $doc;
+
+ my($id,undef,$rev) = db_edit d => $doc->{id}, $data;
+ elm_Changed $id, $rev;
+};
+
+
+json_api '/js/markdown.json', {
+ content => { required => 0, default => '' }
+}, sub {
+ return elm_Unauth if !auth->permDbmod;
+ elm_Content md2html shift->{content};
+};
+
+
+1;
diff --git a/lib/VNWeb/Elm.pm b/lib/VNWeb/Elm.pm
new file mode 100644
index 00000000..ea181e3c
--- /dev/null
+++ b/lib/VNWeb/Elm.pm
@@ -0,0 +1,236 @@
+# This module is responsible for generating elm/Gen/*.
+#
+# It exports an `elm_form` function to generate type definitions, a JSON
+# encoder and HTML5 validation attributes to simplify and synchronize forms.
+#
+# It also exports an `elm_Response` function for each possible API response
+# (see %apis below).
+
+package VNWeb::Elm;
+
+use strict;
+use warnings;
+use TUWF;
+use Exporter 'import';
+use List::Util 'max';
+use VNDB::Config;
+use VNDB::Types;
+use VNWeb::Auth;
+
+our @EXPORT = qw/
+ elm_form
+/;
+
+
+# API response types and arguments. To generate an API response from Perl, call
+# elm_ResponseName(@args), e.g.:
+#
+# elm_Changed $id, $revision;
+#
+# These API responses are available in Elm in the `Gen.Api.Response` union type.
+my %apis = (
+ Unauth => [], # Not authorized
+ Unchanged => [], # No changes
+ Changed => [ { id => 1 }, { uint => 1 } ], # [ id, chrev]; DB entry has been successfully changed
+ Success => [],
+ CSRF => [], # Invalid CSRF token
+ Invalid => [], # POST data did not validate the schema
+ Content => [{}], # Rendered HTML content (for markdown/bbcode APIs)
+);
+
+
+# Generate the elm_Response() functions
+for my $name (keys %apis) {
+ no strict 'refs';
+ $apis{$name} = [ map tuwf->compile($_), $apis{$name}->@* ];
+ *{'elm_'.$name} = sub {
+ my @args = map {
+ $apis{$name}[$_]->validate($_[$_])->data if tuwf->debug;
+ $apis{$name}[$_]->analyze->coerce_for_json($_[$_], unknown => 'reject')
+ } 0..$#{$apis{$name}};
+ tuwf->resJSON({$name, \@args})
+ };
+ push @EXPORT, 'elm_'.$name;
+}
+
+
+
+
+# Formatting functions
+sub indent($) { $_[0] =~ s/\n/\n /gr }
+sub list { indent "\n[ ".join("\n, ", @_)."\n]" }
+sub string($) { '"'.($_[0] =~ s/([\\"])/\\$1/gr).'"' }
+sub tuple { '('.join(', ', @_).')' }
+sub bool($) { $_[0] ? 'True' : 'False' }
+sub to_camel { (ucfirst $_[0]) =~ s/_([a-z])/'_'.uc $1/egr; }
+
+# Generate a variable definition: name, type, value
+sub def($$$) { sprintf "\n%s : %s\n%1\$s = %s\n", @_; }
+
+
+# Generate an Elm type definition corresponding to a TUWF::Validate schema
+sub def_type {
+ my($name, $obj) = @_;
+ my $data = '';
+ my @keys = $obj->{keys} ? grep $obj->{keys}{$_}{keys}||($obj->{keys}{$_}{values}&&$obj->{keys}{$_}{values}{keys}), sort keys $obj->{keys}->%* : ();
+
+ $data .= def_type($name . to_camel($_), $obj->{keys}{$_}{values} || $obj->{keys}{$_}) for @keys;
+
+ $data .= sprintf "\ntype alias %s = %s\n\n", $name, $obj->elm_type(
+ keys => +{ map +($_, ($obj->{keys}{$_}{values} ? 'List ' : '') . $name . to_camel($_)), @keys }
+ );
+ $data
+}
+
+
+# Generate HTML5 validation attribute lists corresponding to a TUWF::Validate schema
+# TODO: Deduplicate some regexes (weburl, email)
+# TODO: Throw these inside a struct for better namespacing?
+sub def_validation {
+ my($name, $obj) = @_;
+ $obj = $obj->{values} if $obj->{values};
+ my $data = '';
+
+ $data .= def_validation($name . to_camel($_), $obj->{keys}{$_}) for $obj->{keys} ? sort keys $obj->{keys}->%* : ();
+
+ my %v = $obj->html5_validation();
+ $data .= def $name, 'List (Html.Attribute msg)', '[ '.join(', ',
+ $v{required} ? 'A.required True' : (),
+ $v{minlength} ? "A.minlength $v{minlength}" : (),
+ $v{maxlength} ? "A.maxlength $v{maxlength}" : (),
+ $v{min} ? "A.min $v{min}" : (),
+ $v{max} ? "A.max $v{max}" : (),
+ $v{pattern} ? 'A.pattern '.string($v{pattern}) : ()
+ ).']' if !$obj->{keys};
+ $data;
+}
+
+
+# Generate an Elm JSON encoder taking a corresponding def_type() as input
+sub encoder {
+ my($name, $type, $obj) = @_;
+ def $name, "$type -> JE.Value", $obj->elm_encoder(json_encode => 'JE.');
+}
+
+
+
+
+sub write_module {
+ my($module, $contents) = @_;
+ my $fn = sprintf '%s/elm/Gen/%s.elm', config->{root}, $module;
+
+ # The imports aren't necessary in all the files, but might as well add them.
+ $contents = <<~"EOF";
+ -- This file is automatically generated from lib/VNWeb/Elm.pm.
+ -- Do not edit, your changes will be lost.
+ module Gen.$module exposing (..)
+ import Http
+ import Html
+ import Html.Attributes as A
+ import Json.Encode as JE
+ import Json.Decode as JD
+ $contents
+ EOF
+
+ # Don't write anything if the file hasn't changed.
+ my $oldcontents = do {
+ local $/=undef; my $F;
+ open($F, '<:utf8', $fn) ? <$F> : '';
+ };
+ return if $oldcontents eq $contents;
+
+ open my $F, '>:utf8', $fn or die "$fn: $!";
+ print $F $contents;
+}
+
+
+
+
+
+# Create type definitions and a JSON encoder for a typical form.
+# Usage:
+#
+# elm_form 'FormName', $TO_ELM_SCHEMA, $TO_SERVER_SCHEMA;
+#
+# That will create a Gen.FormName module with the following definitions:
+#
+# type alias Recv = { .. }
+# type alias Send = { .. }
+# encode : Send -> JE.Value
+# valFieldName : List Html.Attribute
+#
+sub elm_form {
+ return if !tuwf->{elmgen};
+ my($name, $out, $in) = @_;
+
+ my $data = '';
+ $data .= def_type Recv => $out->analyze;
+ $data .= def_type Send => $in->analyze;
+ $data .= encoder encode => 'Send', $in->analyze;
+ $data .= def_validation val => $in->analyze;
+
+ write_module $name, $data;
+}
+
+
+
+# Generate the Gen.Api module with the Response type and decoder.
+sub write_api {
+
+ # Extract all { type => 'hash' } schemas and give them their own
+ # definition, so that it's easy to refer to those records in other places
+ # of the Elm code, similar to def_type().
+ my(@union, @decode);
+ my $data = '';
+ my $len = max map length, keys %apis;
+ for (sort keys %apis) {
+ my($name, $schema) = ($_, $apis{$_});
+ my $def = $name;
+ my $dec = sprintf 'JD.field "%s"%s <| %s', $name,
+ ' 'x($len-(length $name)),
+ @$schema == 0 ? "JD.succeed $name" :
+ @$schema == 1 ? "JD.map $name" : sprintf 'JD.map%d %s', scalar @$schema, $name;
+ my $tname = "Api$name";
+ for my $argn (0..$#$schema) {
+ my $arg = $schema->[$argn]->analyze();
+ my $jd = $arg->elm_decoder(json_decode => 'JD.', level => 3);
+ $dec .= " (JD.index $argn $jd)";
+ if($arg->{keys}) {
+ $data .= def_type $tname, $arg;
+ $def .= " $tname";
+ } elsif($arg->{values} && $arg->{values}{keys}) {
+ $data .= def_type $tname, $arg->{values};
+ $def .= " (List $tname)";
+ } else {
+ $def .= ' '.$arg->elm_type();
+ }
+ }
+ push @union, $def;
+ push @decode, $dec;
+ }
+ $data .= sprintf "\ntype Response\n = HTTPError Http.Error\n | %s\n", join "\n | ", @union;
+ $data .= sprintf "\ndecode : JD.Decoder Response\ndecode = JD.oneOf\n [ %s\n ]", join "\n , ", @decode;
+
+ write_module Api => $data;
+};
+
+
+sub write_types {
+ my $data = '';
+
+ $data .= def urlStatic => String => string config->{url_static};
+
+ write_module Types => $data;
+}
+
+
+if(tuwf->{elmgen}) {
+ mkdir config->{root}.'/elm/Gen';
+ write_api;
+ write_types;
+ open my $F, '>', config->{root}.'/elm/Gen/.generated';
+ print $F scalar gmtime;
+}
+
+
+1;
diff --git a/lib/VNWeb/HTML.pm b/lib/VNWeb/HTML.pm
index 66ab52d6..d1498c1e 100644
--- a/lib/VNWeb/HTML.pm
+++ b/lib/VNWeb/HTML.pm
@@ -21,6 +21,7 @@ our @EXPORT = qw/
debug_
join_
user_
+ elm_
framework_
revision_
/;
@@ -61,6 +62,13 @@ sub user_ {
}
+# Instantiate an Elm module
+sub elm_($$$) {
+ my($mod, $schema, $data) = @_;
+ div_ 'data-elm-module' => 'DocEdit',
+ 'data-elm-flags' => JSON::XS->new->encode($schema->analyze->coerce_for_json($data, unknown => 'remove')), '';
+}
+
sub _head_ {
@@ -78,7 +86,8 @@ sub _head_ {
link_ rel => 'alternate', type => 'application/atom+xml', href => "/feeds/changes.atom", title => 'Recent Changes';
link_ rel => 'alternate', type => 'application/atom+xml', href => "/feeds/posts.atom", title => 'Recent Posts';
}
- meta_ name => 'robots', content => 'noindex, follow' if $o->{noindex};
+ meta_ name => 'csrf-token', content => auth->csrftoken;
+ meta_ name => 'robots', content => 'noindex' if defined $o->{index} && !$o->{index};
# Opengraph metadata
if($o->{og}) {
@@ -288,7 +297,7 @@ sub _hidden_msg_ {
# Options:
# title => $title
-# noindex => 1/0
+# index => 1/0, default 1
# feeds => 1/0
# search => $query
# og => { opengraph metadata }
@@ -313,7 +322,8 @@ sub framework_ {
_maintabs_ \%o;
$cont->() unless $o{hiddenmsg} && _hidden_msg_ \%o;
div_ id => 'footer', \&_footer_;
- }
+ };
+ script_ type => 'application/javascript', src => config->{url_static}.'/f/v2rw.js', '';
}
}
}
diff --git a/lib/VNWeb/Prelude.pm b/lib/VNWeb/Prelude.pm
index ecc5a606..26d0763e 100644
--- a/lib/VNWeb/Prelude.pm
+++ b/lib/VNWeb/Prelude.pm
@@ -14,6 +14,10 @@
# use VNWeb::Auth;
# use VNWeb::HTML;
# use VNWeb::DB;
+# use VNWeb::Validation;
+# use VNWeb::Elm;
+#
+# + A few other handy tools.
#
# WARNING: This should not be used from the above modules.
package VNWeb::Prelude;
@@ -22,6 +26,11 @@ use strict;
use warnings;
use feature ':5.26';
use utf8;
+use VNWeb::Elm;
+use VNWeb::Auth;
+use TUWF;
+use JSON::XS;
+
sub import {
my $c = caller;
@@ -44,11 +53,14 @@ sub import {
use VNWeb::Auth;
use VNWeb::HTML;
use VNWeb::DB;
+ use VNWeb::Validation;
+ use VNWeb::Elm;
1;
EOM;
no strict 'refs';
*{$c.'::RE'} = *RE;
+ *{$c.'::json_api'} = \&json_api;
}
@@ -73,4 +85,39 @@ our %RE = (
drev => qr{d$id$rev?},
);
+
+
+# Easy wrapper to create a simple API that accepts JSON data on POST requests.
+# The CSRF token and the input data are validated before the subroutine is
+# called.
+#
+# Usage:
+#
+# json_api '/some/url', {
+# username => { maxlength => 10 },
+# }, sub {
+# my $validated_data = shift;
+# };
+sub json_api {
+ my($path, $keys, $sub) = @_;
+
+ my $schema = ref $keys eq 'HASH' ? tuwf->compile({ type => 'hash', keys => $keys }) : $keys;
+
+ TUWF::post $path => sub {
+ if(!auth->csrfcheck(tuwf->reqHeader('X-CSRF-Token')||'')) {
+ warn "Invalid CSRF token in request\n";
+ return elm_CSRF;
+ }
+
+ my $data = tuwf->validate(json => $schema);
+ if(!$data) {
+ warn "JSON validation failed\ninput: " . JSON::XS->new->allow_nonref->pretty->canonical->encode(tuwf->reqJSON) . "\nerror: " . JSON::XS->new->encode($data->err) . "\n";
+ return elm_Invalid;
+ }
+
+ $sub->($data->data);
+ warn "Non-JSON response to a json_api request, is this intended?\n" if tuwf->resHeader('Content-Type') !~ /^application\/json/;
+ };
+}
+
1;
diff --git a/lib/VNWeb/Validation.pm b/lib/VNWeb/Validation.pm
index a014b11d..80af1d34 100644
--- a/lib/VNWeb/Validation.pm
+++ b/lib/VNWeb/Validation.pm
@@ -6,10 +6,76 @@ use VNWeb::Auth;
use Exporter 'import';
our @EXPORT = qw/
+ form_compile
+ form_changed
can_edit
/;
+TUWF::set custom_validations => {
+ id => { uint => 1, max => 1<<40 },
+ editsum => { required => 1, length => [ 2, 5000 ] },
+};
+
+
+# Recursively remove keys from hashes that have a '_when' key that doesn't
+# match $when. This is a quick and dirty way to create multiple validation
+# schemas from a single schema. For example:
+#
+# {
+# title => { _when => 'input' },
+# name => { },
+# }
+#
+# If $when is 'input', then this function returns:
+# { title => {}, name => {} }
+# Otherwise, it returns:
+# { name => {} }
+sub _stripwhen {
+ my($when, $o) = @_;
+ return $o if ref $o ne 'HASH';
+ +{ map $_ eq '_when' || (ref $o->{$_} eq 'HASH' && defined $o->{$_}{_when} && $o->{$_}{_when} !~ $when) ? () : ($_, _stripwhen($when, $o->{$_})), keys %$o }
+}
+
+
+# Short-hand to compile a validation schema for a form. Usage:
+#
+# form_compile $when, {
+# title => { _when => 'input' },
+# name => { },
+# ..
+# };
+sub form_compile {
+ tuwf->compile({ type => 'hash', keys => _stripwhen @_ });
+}
+
+
+sub _eq_deep {
+ my($a, $b) = @_;
+ return 0 if ref $a ne ref $b;
+ return 0 if defined $a != defined $b;
+ return 1 if !defined $a;
+ return 1 if !ref $a && $a eq $b;
+ return 1 if ref $a eq 'ARRAY' && (@$a == @$b && !grep !_eq_deep($a->[$_], $b->[$_]), 0..$#$a);
+ return 1 if ref $a eq 'HASH' && _eq_deep([sort keys %$a], [sort keys %$b]) && !grep !_eq_deep($a->{$_}, $b->{$_}), keys %$a;
+ 0
+}
+
+
+# Usage: form_changed $schema, $a, $b
+# Returns 1 if there is a difference between the data ($a) and the form input
+# ($b), using the normalization defined in $schema. The $schema must validate.
+sub form_changed {
+ my($schema, $a, $b) = @_;
+ my $na = $schema->validate($a)->data;
+ my $nb = $schema->validate($b)->data;
+
+ #warn "a=".JSON::XS->new->pretty->canonical->encode($na);
+ #warn "b=".JSON::XS->new->pretty->canonical->encode($nb);
+ !_eq_deep $na, $nb;
+}
+
+
# Returns whether the current user can edit the given database entry.
sub can_edit {
my($type, $entry) = @_;
generated by cgit v1.2.3 (git 2.25.1) at 2024-04-19 12:03:34 +0000