summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--elm/Lib/Api.elm1
-rw-r--r--elm/Lib/Html.elm3
-rw-r--r--elm/TagEdit.elm198
-rw-r--r--lib/VNDB/Handler/Tags.pm8
-rw-r--r--lib/VNWeb/Elm.pm5
-rw-r--r--lib/VNWeb/Tags/Edit.pm118
-rw-r--r--lib/VNWeb/Validation.pm8
7 files changed, 336 insertions, 5 deletions
diff --git a/elm/Lib/Api.elm b/elm/Lib/Api.elm
index fd4a3a7e..b1e22193 100644
--- a/elm/Lib/Api.elm
+++ b/elm/Lib/Api.elm
@@ -45,6 +45,7 @@ showResponse res =
BadCurPass -> "Current password is invalid."
MailChange -> unexp
ImgFormat -> "Unrecognized image format, only JPEG and PNG are accepted."
+ DupNames _ -> "Name or alias already in the database."
Releases _ -> unexp
BoardResult _ -> unexp
TagResult _ -> unexp
diff --git a/elm/Lib/Html.elm b/elm/Lib/Html.elm
index 2d7d516c..440abd00 100644
--- a/elm/Lib/Html.elm
+++ b/elm/Lib/Html.elm
@@ -125,10 +125,11 @@ inputTextArea nam val onch attrs = textarea (
, onInput onch
, rows 4
, cols 50
+ , value val
]
++ attrs
++ (if nam == "" then [] else [ id nam, name nam ])
- ) [ text val ]
+ ) []
inputCheck : String -> Bool -> (Bool -> m) -> Html m
diff --git a/elm/TagEdit.elm b/elm/TagEdit.elm
new file mode 100644
index 00000000..9a06e855
--- /dev/null
+++ b/elm/TagEdit.elm
@@ -0,0 +1,198 @@
+module TagEdit exposing (main)
+
+import Html exposing (..)
+import Html.Attributes exposing (..)
+import Browser
+import Browser.Navigation exposing (load)
+import Lib.Html exposing (..)
+import Lib.TextPreview as TP
+import Lib.Api as Api
+import Lib.Util exposing (..)
+import Lib.Autocomplete as A
+import Lib.Ffi as Ffi
+import Gen.Api as GApi
+import Gen.Types exposing (tagCategories)
+import Gen.TagEdit as GTE
+
+
+main : Program GTE.Recv Model Msg
+main = Browser.element
+ { init = \e -> (init e, Cmd.none)
+ , view = view
+ , update = update
+ , subscriptions = always Sub.none
+ }
+
+
+type alias Model =
+ { formstate : Api.State
+ , id : Maybe Int
+ , name : String
+ , aliases : String
+ , state : Int
+ , cat : String
+ , description : TP.Model
+ , searchable : Bool
+ , applicable : Bool
+ , defaultspoil : Int
+ , parents : List GTE.RecvParents
+ , parentAdd : A.Model GApi.ApiTagResult
+ , addedby : String
+ , canMod : Bool
+ , dupNames : List GApi.ApiDupNames
+ }
+
+
+init : GTE.Recv -> Model
+init d =
+ { formstate = Api.Normal
+ , id = d.id
+ , name = d.name
+ , aliases = String.join "\n" d.aliases
+ , state = d.state
+ , cat = d.cat
+ , description = TP.bbcode d.description
+ , searchable = d.searchable
+ , applicable = d.applicable
+ , defaultspoil = d.defaultspoil
+ , parents = d.parents
+ , parentAdd = A.init ""
+ , addedby = d.addedby
+ , canMod = d.can_mod
+ , dupNames = []
+ }
+
+
+splitAliases : String -> List String
+splitAliases l = String.lines l |> List.map String.trim |> List.filter (\s -> s /= "")
+
+findDup : Model -> String -> List GApi.ApiDupNames
+findDup model a = List.filter (\t -> String.toLower t.name == String.toLower a) model.dupNames
+
+isValid : Model -> Bool
+isValid model = not (List.any (findDup model >> List.isEmpty >> not) (model.name :: splitAliases model.aliases))
+
+parentConfig : A.Config Msg GApi.ApiTagResult
+parentConfig = { wrap = ParentSearch, id = "parentadd", source = A.tagSource }
+
+
+encode : Model -> GTE.Send
+encode m =
+ { id = m.id
+ , name = m.name
+ , aliases = splitAliases m.aliases
+ , state = m.state
+ , cat = m.cat
+ , description = m.description.data
+ , searchable = m.searchable
+ , applicable = m.applicable
+ , defaultspoil = m.defaultspoil
+ , parents = List.map (\l -> {id=l.id}) m.parents
+ }
+
+
+type Msg
+ = Noop
+ | Name String
+ | Aliases String
+ | State Int
+ | Searchable Bool
+ | Applicable Bool
+ | Cat String
+ | DefaultSpoil Int
+ | Description TP.Msg
+ | ParentDel Int
+ | ParentSearch (A.Msg GApi.ApiTagResult)
+ | Submit
+ | Submitted (GApi.Response)
+
+
+update : Msg -> Model -> (Model, Cmd Msg)
+update msg model =
+ case msg of
+ Noop -> (model, Cmd.none)
+ Name s -> ({ model | name = s }, Cmd.none)
+ Aliases s -> ({ model | aliases = String.replace "," "\n" s }, Cmd.none)
+ State n -> ({ model | state = n }, Cmd.none)
+ Searchable b -> ({ model | searchable = b }, Cmd.none)
+ Applicable b -> ({ model | applicable = b }, Cmd.none)
+ Cat s -> ({ model | cat = s }, Cmd.none)
+ DefaultSpoil n-> ({ model | defaultspoil = n }, Cmd.none)
+ Description m -> let (nm,nc) = TP.update m model.description in ({ model | description = nm }, Cmd.map Description nc)
+
+ ParentDel i -> ({ model | parents = delidx i model.parents }, Cmd.none)
+ ParentSearch m ->
+ let (nm, c, res) = A.update parentConfig m model.parentAdd
+ in case res of
+ Nothing -> ({ model | parentAdd = nm }, c)
+ Just p ->
+ if List.any (\e -> e.id == p.id) model.parents
+ then ({ model | parentAdd = nm }, c)
+ else ({ model | parentAdd = A.clear nm "", parents = model.parents ++ [{ id = p.id, name = p.name}] }, c)
+
+ Submit -> ({ model | formstate = Api.Loading }, GTE.send (encode model) Submitted)
+ Submitted (GApi.DupNames l) -> ({ model | dupNames = l, formstate = Api.Normal }, Cmd.none)
+ Submitted (GApi.Redirect s) -> (model, load s)
+ Submitted r -> ({ model | formstate = Api.Error r }, Cmd.none)
+
+
+view : Model -> Html Msg
+view model =
+ form_ Submit (model.formstate == Api.Loading)
+ [ div [ class "mainbox" ]
+ [ h1 [] [ text <| if model.id == Nothing then "Submit new tag" else "Edit tag" ]
+ , table [ class "formtable" ] <|
+ [ if model.id == Nothing then text "" else
+ formField "Added by" [ span [ Ffi.innerHtml model.addedby ] [], br_ 2 ]
+ , formField "name::Primary name" [ inputText "name" model.name Name GTE.valName ]
+ , formField "aliases::Aliases"
+ -- BUG: Textarea doesn't validate the maxlength and patterns for aliases, we don't have a client-side fallback check either.
+ [ inputTextArea "aliases" model.aliases Aliases []
+ , let dups = List.concatMap (findDup model) (model.name :: splitAliases model.aliases)
+ in if List.isEmpty dups
+ then span [] [ br [] [], text "Tag name and aliases must be unique and self-describing." ]
+ else div []
+ [ b [ class "standout" ] [ text "The following tag names are already present in the database:" ]
+ , ul [] <| List.map (\t ->
+ li [] [ a [ href ("/g"++String.fromInt t.id) ] [ text t.name ] ]
+ ) dups
+ ]
+ ]
+ , tr [ class "newpart" ] [ td [ colspan 2 ] [ text "" ] ]
+ , if not model.canMod then text "" else
+ formField "state::State" [ inputSelect "state" model.state State GTE.valState
+ [ (0, "Awaiting Moderation")
+ , (1, "Deleted/hidden")
+ , (2, "Approved")
+ ]
+ ]
+ , if not model.canMod then text "" else
+ formField "" [ label [] [ inputCheck "" model.searchable Searchable, text " Searchable (people can use this tag to find VNs)" ] ]
+ , if not model.canMod then text "" else
+ formField "" [ label [] [ inputCheck "" model.applicable Applicable, text " Applicable (people can apply this tag to VNs)" ] ]
+ , formField "cat::Category" [ inputSelect "cat" model.cat Cat GTE.valCat tagCategories ]
+ , formField "defaultspoil::Default spoiler level" [ inputSelect "defaultspoil" model.defaultspoil DefaultSpoil GTE.valDefaultspoil
+ [ (0, "No spoiler")
+ , (1, "Minor spoiler")
+ , (2, "Major spoiler")
+ ] ]
+ , text "" -- aliases
+ , formField "description::Description"
+ [ TP.view "description" model.description Description 700 ([rows 12, cols 50] ++ GTE.valDescription) []
+ , text "What should the tag be used for? Having a good description helps users choose which tags to link to a VN."
+ ]
+ , tr [ class "newpart" ] [ td [ colspan 2 ] [ text "" ] ]
+ , formField "Parent tags"
+ [ table [ class "compact" ] <| List.indexedMap (\i p -> tr []
+ [ td [ style "text-align" "right" ] [ b [ class "grayedout" ] [ text <| "g" ++ String.fromInt p.id ++ ":" ] ]
+ , td [] [ a [ href <| "/g" ++ String.fromInt p.id ] [ text p.name ] ]
+ , td [] [ inputButton "remove" (ParentDel i) [] ]
+ ]
+ ) model.parents
+ , A.view parentConfig model.parentAdd [placeholder "Add parent tag..."]
+ ]
+ ]
+ ]
+ , div [ class "mainbox" ]
+ [ fieldset [ class "submit" ] [ submitButton "Submit" model.formstate (isValid model) ] ]
+ ]
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});