v2rw/TagEdit: Rewrite tag edit form to elm

It's still missing a few mod features, will add those later.

4 files changed, 135 insertions, 4 deletions

diff --git a/lib/VNDB/Handler/Tags.pm b/lib/VNDB/Handler/Tags.pm
index 55bf99db..9db1667f 100644
--- a/lib/VNDB/Handler/Tags.pm
+++ b/lib/VNDB/Handler/Tags.pm
@@ -11,9 +11,9 @@ use VNDB::Types;
 
 TUWF::register(
   qr{g([1-9]\d*)},          \&tagpage,
-  qr{g([1-9]\d*)/(edit)},   \&tagedit,
-  qr{g([1-9]\d*)/(add)},    \&tagedit,
-  qr{g/new},                \&tagedit,
+  qr{old/g([1-9]\d*)/(edit)},   \&tagedit,
+  qr{old/g([1-9]\d*)/(add)},    \&tagedit,
+  qr{old/g/new},                \&tagedit,
   qr{g/list},               \&taglist,
   qr{u([1-9]\d*)/tags},     \&usertags,
   qr{g},                    \&tagindex,
@@ -249,7 +249,7 @@ sub tagedit {
     end;
   }
 
-  $self->htmlForm({ frm => $frm, action => $par ? "/g$par->{id}/add" : $tag ? "/g$tag/edit" : '/g/new' }, 'tagedit' => [ $title,
+  $self->htmlForm({ frm => $frm, action => $par ? "/old/g$par->{id}/add" : $tag ? "/old/g$tag/edit" : '/old/g/new' }, 'tagedit' => [ $title,
     [ input    => short => 'name',     name => 'Primary name' ],
     $self->authCan('tagmod') ? (
       $tag ?
diff --git a/lib/VNWeb/Elm.pm b/lib/VNWeb/Elm.pm
index b6a3b710..4e9d435b 100644
--- a/lib/VNWeb/Elm.pm
+++ b/lib/VNWeb/Elm.pm
@@ -51,6 +51,10 @@ our %apis = (
     BadCurPass     => [], # Current password is incorrect when changing password
     MailChange     => [], # A confirmation mail has been sent to change a user's email address
     ImgFormat      => [], # Unrecognized image format
+    DupNames       => [ { aoh => { # Duplicate names/aliases (for tags & traits)
+        id       => { id => 1 },
+        name     => {},
+    } } ],
     Releases       => [ { aoh => { # Response to 'Release'
         id       => { id => 1 },
         title    => {},
@@ -416,6 +420,7 @@ sub write_types {
     $data .= def creditTypes=> 'List (String, String)' => list map tuple(string $_, string $CREDIT_TYPE{$_}), keys %CREDIT_TYPE;
     $data .= def producerRelations=> 'List (String, String)' => list map tuple(string $_, string $PRODUCER_RELATION{$_}{txt}), keys %PRODUCER_RELATION;
     $data .= def producerTypes=> 'List (String, String)' => list map tuple(string $_, string $PRODUCER_TYPE{$_}), keys %PRODUCER_TYPE;
+    $data .= def tagCategories=> 'List (String, String)' => list map tuple(string $_, string $TAG_CATEGORY{$_}), keys %TAG_CATEGORY;
     $data .= def curYear    => Int => (gmtime)[5]+1900;
 
     write_module Types => $data;
diff --git a/lib/VNWeb/Tags/Edit.pm b/lib/VNWeb/Tags/Edit.pm
new file mode 100644
index 00000000..57e963c0
--- /dev/null
+++ b/lib/VNWeb/Tags/Edit.pm
@@ -0,0 +1,118 @@
+package VNWeb::Tags::Edit;
+
+use VNWeb::Prelude;
+
+# TODO: Let users edit their own tag while it's still waiting for approval?
+
+my $FORM = {
+    id           => { required => 0, id => 1 },
+    name         => { maxlength => 250, regex => qr/^[^,\r\n]+$/ },
+    aliases      => { type => 'array', values => { maxlength => 250, regex => qr/^[^,\r\n]+$/ } },
+    state        => { uint => 1, range => [0,2] },
+    cat          => { enum => \%TAG_CATEGORY, default => 'cont' },
+    description  => { maxlength => 10240 },
+    searchable   => { anybool => 1, default => 1 },
+    applicable   => { anybool => 1, default => 1 },
+    defaultspoil => { uint => 1, range => [0,2] },
+    parents      => { aoh => {
+        id          => { id => 1 },
+        name        => { _when => 'out' },
+    } },
+    # TODO: delete/merge/wipevotes
+
+    addedby      => { _when => 'out' },
+    can_mod      => { _when => 'out', anybool => 1 },
+};
+
+my $FORM_OUT = form_compile out => $FORM;
+my $FORM_IN  = form_compile in  => $FORM;
+
+
+TUWF::get qr{/$RE{gid}/edit}, sub {
+    my $g = tuwf->dbRowi('
+        SELECT g.id, g.name, g.description, g.state, g.cat, g.defaultspoil, g.searchable, g.applicable
+             , ', sql_user('u', 'addedby_'), '
+          FROM tags g
+          LEFT JOIN users u ON g.addedby = u.id
+         WHERE g.id =', \tuwf->capture('id')
+    );
+    return tuwf->resNotFound if !$g->{id};
+
+    enrich_flatten aliases => id => tag => 'SELECT tag, alias FROM tags_aliases WHERE tag IN', $g;
+    enrich parents => id => tag => 'SELECT gp.tag, g.id, g.name FROM tags_parents gp JOIN tags g ON g.id = gp.parent WHERE gp.tag IN', $g;
+
+    return tuwf->resDenied if !can_edit g => $g;
+
+    $g->{addedby} = xml_string sub { user_ $g, 'addedby_'; };
+    $g->{can_mod} = auth->permTagmod;
+
+    framework_ title => "Edit $g->{name}", type => 'g', dbobj => $g, tab => 'edit', sub {
+        elm_ TagEdit => $FORM_OUT, $g;
+    };
+};
+
+
+TUWF::get qr{/(?:$RE{gid}/add|g/new)}, sub {
+    my $id = tuwf->capture('id');
+    my $g = tuwf->dbRowi('SELECT id, name, cat FROM tags WHERE id =', \$id);
+    return tuwf->resDenied if !can_edit g => {};
+    return tuwf->resNotFound if $id && !$g->{id};
+
+    my $e = elm_empty($FORM_OUT);
+    $e->{can_mod} = auth->permTagmod;
+    if($id) {
+        $e->{parents} = [$g];
+        $e->{cat} = $g->{cat};
+    }
+
+    framework_ title => 'Submit a new tag', sub {
+        elm_ TagEdit => $FORM_OUT, $e;
+    };
+};
+
+
+elm_api TagEdit => $FORM_OUT, $FORM_IN, sub {
+    my($data) = @_;
+    my $id = delete $data->{id};
+    my $g = !$id ? {} : tuwf->dbRowi('SELECT id, addedby FROM tags WHERE id =', \$id);
+    return tuwf->resNotFound if $id && !$g->{id};
+    return elm_Unauth if !can_edit g => $g;
+
+
+    $data->{addedby} = $g->{addedby} // auth->uid;
+    if(!auth->permTagmod) {
+        $data->{state} = 0;
+        $data->{applicable} = $data->{searchable} = 1;
+    }
+
+    my $dups = tuwf->dbAlli('
+        SELECT id, name
+          FROM (SELECT id, name FROM tags UNION SELECT tag, alias FROM tags_aliases) n(id,name)
+         WHERE ', sql_and(
+             $id ? sql 'id <>', \$id : (),
+             sql 'lower(name) IN', [ map lc($_), $data->{name}, $data->{aliases}->@* ]
+         )
+    );
+    return elm_DupNames $dups if @$dups;
+
+    # Make sure parent IDs exists and are not a child tag of the current tag (i.e. don't allow cycles)
+    validate_dbid sub {
+        'SELECT id FROM tags WHERE', sql_and
+            $id ? sql 'id NOT IN(WITH RECURSIVE t(id) AS (SELECT', \$id, '::int UNION SELECT tag FROM tags_parents tp JOIN t ON t.id = tp.parent) SELECT id FROM t)' : (),
+            sql 'id IN', $_[0]
+    }, map $_->{id}, $data->{parents}->@*;
+
+    my %set = map +($_,$data->{$_}), qw/name description state addedby cat defaultspoil searchable applicable/;
+    tuwf->dbExeci('UPDATE tags SET', \%set, 'WHERE id =', \$id) if $id;
+    $id = tuwf->dbVali('INSERT INTO tags', \%set, 'RETURNING id') if !$id;
+
+    tuwf->dbExeci('DELETE FROM tags_aliases WHERE tag =', \$id);
+    tuwf->dbExeci('INSERT INTO tags_aliases (tag,alias) VALUES(', \$id, ',', \$_, ')') for $data->{aliases}->@*;
+
+    tuwf->dbExeci('DELETE FROM tags_parents WHERE tag =', \$id);
+    tuwf->dbExeci('INSERT INTO tags_parents (tag,parent) VALUES(', \$id, ',', \$_->{id}, ')') for $data->{parents}->@*;
+
+    elm_Redirect "/g$id";
+};
+
+1;
diff --git a/lib/VNWeb/Validation.pm b/lib/VNWeb/Validation.pm
index 4d398aac..e457aba2 100644
--- a/lib/VNWeb/Validation.pm
+++ b/lib/VNWeb/Validation.pm
@@ -182,6 +182,10 @@ sub validate_dbid {
 #     Otherwise, checks if the user can edit the review.
 #       Requires the 'uid' field.
 #
+#   g/i:
+#     If no 'id' field, checks if the user can create a new tag/trait.
+#     Otherwise, checks if the user can edit the entry.
+#
 #   'dbentry_type's:
 #     If no 'id' field, checks whether the user can create a new entry.
 #     Otherwise, requires 'entry_hidden' and 'entry_locked' fields.
@@ -214,6 +218,10 @@ sub can_edit {
         return auth && auth->uid == $entry->{user_id};
     }
 
+    if($type eq 'g' || $type eq 'i') {
+        return auth && (auth->permTagmod || !$entry->{id});
+    }
+
     die "Can't do authorization test when entry_hidden/entry_locked fields aren't present"
         if $entry->{id} && (!exists $entry->{entry_hidden} || !exists $entry->{entry_locked});