diff options
-rw-r--r-- | elm/Lib/Api.elm | 1 | ||||
-rw-r--r-- | elm/Lib/Html.elm | 3 | ||||
-rw-r--r-- | elm/TagEdit.elm | 198 | ||||
-rw-r--r-- | lib/VNDB/Handler/Tags.pm | 8 | ||||
-rw-r--r-- | lib/VNWeb/Elm.pm | 5 | ||||
-rw-r--r-- | lib/VNWeb/Tags/Edit.pm | 118 | ||||
-rw-r--r-- | lib/VNWeb/Validation.pm | 8 |
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}); |