diff options
Diffstat (limited to 'lib')
36 files changed, 0 insertions, 5220 deletions
diff --git a/lib/VN3/BBCode.pm b/lib/VN3/BBCode.pm deleted file mode 100644 index a9922b4c..00000000 --- a/lib/VN3/BBCode.pm +++ /dev/null @@ -1,300 +0,0 @@ -package VN3::BBCode; - -use strict; -use warnings; -use v5.10; -use Exporter 'import'; -use TUWF::XML 'xml_escape'; - -our @EXPORT = qw/bb2html bb2text bb_subst_links/; - -# Supported BBCode: -# [spoiler] .. [/spoiler] -# [quote] .. [/quote] -# [code] .. [/code] -# [url=..] [/url] -# [raw] .. [/raw] -# link: http://../ -# dblink: v+, v+.+, d+#+, d+#+.+ -# -# Permitted nesting of formatting codes: -# spoiler -> url, raw, link, dblink -# quote -> anything -# code -> nothing -# url -> raw -# raw -> nothing - - -# State action function usage: -# _state_action \@stack, $match, $char_pre, $char_post -# Returns: ($token, @arg) on successful parse, () otherwise. - -# Trivial open and close actions -sub _spoiler_start { if(lc$_[1] eq '[spoiler]') { push @{$_[0]}, 'spoiler'; ('spoiler_start') } else { () } } -sub _quote_start { if(lc$_[1] eq '[quote]') { push @{$_[0]}, 'quote'; ('quote_start') } else { () } } -sub _code_start { if(lc$_[1] eq '[code]') { push @{$_[0]}, 'code'; ('code_start') } else { () } } -sub _raw_start { if(lc$_[1] eq '[raw]') { push @{$_[0]}, 'raw'; ('raw_start') } else { () } } -sub _spoiler_end { if(lc$_[1] eq '[/spoiler]') { pop @{$_[0]}; ('spoiler_end') } else { () } } -sub _quote_end { if(lc$_[1] eq '[/quote]' ) { pop @{$_[0]}; ('quote_end' ) } else { () } } -sub _code_end { if(lc$_[1] eq '[/code]' ) { pop @{$_[0]}; ('code_end' ) } else { () } } -sub _raw_end { if(lc$_[1] eq '[/raw]' ) { pop @{$_[0]}; ('raw_end' ) } else { () } } -sub _url_end { if(lc$_[1] eq '[/url]' ) { pop @{$_[0]}; ('url_end' ) } else { () } } - -sub _url_start { - if($_[1] =~ m{^\[url=((https?://|/)[^\]>]+)\]$}i) { - push @{$_[0]}, 'url'; - (url_start => $1) - } else { () } -} - -sub _link { - my(undef, $match, $char_pre, $char_post) = @_; - - # Tags arent links - return () if $match =~ /^\[/; - - # URLs (already "validated" in the parsing regex) - return ('link') if $match =~ /^[hf]t/; - - # Now we're left with various forms of IDs, just need to make sure it's not surrounded by word characters - return ('dblink') if $char_pre !~ /\w/ && $char_post !~ /\w/; - - (); -} - - -# Permitted actions to take in each state. The actions are run in order, if -# none succeed then the token is passed through as text. -# The "current state" is the most recent tag in the stack, or '' if no tags are open. -my %STATE = ( - '' => [ \&_link, \&_url_start, \&_raw_start, \&_spoiler_start, \&_quote_start, \&_code_start], - spoiler => [\&_spoiler_end, \&_link, \&_url_start, \&_raw_start], - quote => [\&_quote_end, \&_link, \&_url_start, \&_raw_start, \&_spoiler_start, \&_quote_start, \&_code_start], - code => [\&_code_end ], - url => [\&_url_end, \&_raw_start], - raw => [\&_raw_end ], -); - - -# Usage: -# -# parse $input, sub { -# my($raw, $token, @arg) = @_; -# return 1; # to continue processing, 0 to stop. (Note that _close tokens may still follow after stopping) -# }; -# -# $raw = the raw part that has been parsed -# $token = name of the parsed bbcode token, with some special cases (see below) -# @arg = $token-specific arguments. -# -# Tags: -# text -> literal text, $raw is the text to display -# spoiler_start -> start a spoiler -# spoiler_end -> end -# quote_start -> start a quote -# quote_end -> end -# code_start -> code block -# code_end -> end -# url_start -> [url=..], $arg[0] contains the url -# url_end -> [/url] -# raw_start -> [raw] -# raw_end -> [/raw] -# link -> http://.../, $raw is the link -# dblink -> v123, t13.1, etc. $raw is the dblink -# -# This function will ensure correct nesting of _start and _end tokens. -sub parse { - my($raw, $sub) = @_; - $raw =~ s/\r//g; - return if !$raw && $raw ne '0'; - - my $last = 0; - my @stack; - - while($raw =~ m{(?: - \[ \/? (?i: spoiler|quote|code|url|raw ) [^\s\]]* \] | # tag - d[1-9][0-9]* \# [1-9][0-9]* (?: \.[1-9][0-9]* )? | # d+#+[.+] - [tdvprcs][1-9][0-9]*\.[1-9][0-9]* | # v+.+ - [tdvprcsugi][1-9][0-9]* | # v+ - (?:https?|ftp)://[^><"\n\s\]\[]+[\d\w=/-] # link - )}xg) { - my $token = $&; - my $pre = substr $raw, $last, $-[0]-$last; - my $char_pre = $-[0] ? substr $raw, $-[0]-1, 1 : ''; - $last = pos $raw; - my $char_post = substr $raw, $last, 1; - - # Pass through the unformatted text before the match - $sub->($pre, 'text') || goto FINAL if length $pre; - - # Call the state functions. Arguments to these functions are implicitely - # passed through @_, which avoids allocating a new stack for each function - # call. - my $state = $STATE{ $stack[$#stack]||'' }; - my @ret; - @_ = (\@stack, $token, $char_pre, $char_post); - for(@$state) { - @ret = &$_; - last if @ret; - } - $sub->($token, @ret ? @ret : ('text')) || goto FINAL; - } - - $sub->(substr($raw, $last), 'text') if $last < length $raw; - -FINAL: - # Close all tags. This code is a bit of a hack, as it bypasses the state actions. - $sub->('', "${_}_end") for reverse @stack; -} - - -sub bb2html { - my($input, $maxlength, $charspoil) = @_; - - my $incode = 0; - my $rmnewline = 0; - my $length = 0; - my $ret = ''; - - # escapes, returns string, and takes care of $length and $maxlength; also - # takes care to remove newlines and double spaces when necessary - my $e = sub { - local $_ = shift; - - s/^\n// if $rmnewline && $rmnewline--; - s/\n{5,}/\n\n/g if !$incode; - s/ +/ /g if !$incode; - $length += length $_; - if($maxlength && $length > $maxlength) { - $_ = substr($_, 0, $maxlength-$length); - s/\W+\w*$//; # cleanly cut off on word boundary - } - s/&/&/g; - s/>/>/g; - s/</</g; - s/\n/<br>/g if !$maxlength; - s/\n/ /g if $maxlength; - $_; - }; - - parse $input, sub { - my($raw, $tag, @arg) = @_; - - #$ret .= "$tag {$raw}\n"; - #return 1; - - if($tag eq 'text') { - $ret .= $e->($raw); - - } elsif($tag eq 'spoiler_start') { - $ret .= !$charspoil - ? '<b class="spoiler">' - : '<b class="grayedout charspoil charspoil_-1"><hidden by spoiler settings></b><span class="charspoil charspoil_2 hidden">'; - } elsif($tag eq 'spoiler_end') { - $ret .= !$charspoil ? '</b>' : '</span>'; - - } elsif($tag eq 'quote_start') { - $ret .= '<div class="quote">' if !$maxlength; - $rmnewline = 1; - } elsif($tag eq 'quote_end') { - $ret .= '</div>' if !$maxlength; - $rmnewline = 1; - - } elsif($tag eq 'code_start') { - $ret .= '<pre>' if !$maxlength; - $rmnewline = 1; - $incode = 1; - } elsif($tag eq 'code_end') { - $ret .= '</pre>' if !$maxlength; - $rmnewline = 1; - $incode = 0; - - } elsif($tag eq 'url_start') { - $ret .= sprintf '<a href="%s" rel="nofollow">', xml_escape($arg[0]); - } elsif($tag eq 'url_end') { - $ret .= '</a>'; - - } elsif($tag eq 'link') { - $ret .= sprintf '<a href="%s" rel="nofollow">%s</a>', xml_escape($raw), $e->('link'); - - } elsif($tag eq 'dblink') { - (my $link = $raw) =~ s/^d(\d+)\.(\d+)\.(\d+)$/d$1#$2.$3/; - $ret .= sprintf '<a href="/%s">%s</a>', $link, $e->($raw); - } - - !$maxlength || $length < $maxlength; - }; - $ret; -} - - -# Convert bbcode into plain text, stripping all tags and spoilers. [url] tags -# only display the title. -sub bb2text { - my $input = shift; - - my $inspoil = 0; - my $ret = ''; - parse $input, sub { - my($raw, $tag, @arg) = @_; - if($tag eq 'spoiler_start') { - $inspoil = 1; - } elsif($tag eq 'spoiler_end') { - $inspoil = 0; - } else { - $ret .= $raw if !$inspoil && $tag !~ /_(start|end)$/; - } - 1; - }; - $ret; -} - - -# Turn (most) 'dblink's into [url=..] links. This function relies on TUWF to do -# the database querying, so can't be used from Multi. -# Doesn't handle: -# - d+, t+, r+ and u+ links -# - item revisions -sub bb_subst_links { - my $msg = shift; - - # Parse a message and create an index of links to resolve - my %lookup; - parse $msg, sub { - my($code, $tag) = @_; - $lookup{$1}{$2} = 1 if $tag eq 'dblink' && $code =~ /^(.)(\d+)/; - 1; - }; - return $msg unless %lookup; - - # Now resolve the links - state $types = { # Query must return 'id' and 'name' columns, list of IDs will be appended to it. - v => 'SELECT id, title AS name FROM vn WHERE id IN', - c => 'SELECT id, name FROM chars WHERE id IN', - p => 'SELECT id, name FROM producers WHERE id IN', - g => 'SELECT id, name FROM tags WHERE id IN', - i => 'SELECT id, name FROM traits WHERE id IN', - s => 'SELECT s.id, sa.name FROM staff_alias sa JOIN staff s ON s.aid = sa.id WHERE s.id IN', - }; - my %links; - for my $type (keys %$types) { - next if !$lookup{$type}; - my $lst = $TUWF::OBJ->dbAlli($types->{$type}, [keys %{$lookup{$type}}]); - $links{$type . $_->{id}} = $_->{name} for @$lst; - } - return $msg unless %links; - - # Now substitute - my $result = ''; - parse $msg, sub { - my($code, $tag) = @_; - $result .= $tag eq 'dblink' && $links{$code} - ? sprintf '[url=/%s]%s[/url]', $code, $links{$code} - : $code; - 1; - }; - return $result; -} - - -1; diff --git a/lib/VN3/Char/Edit.pm b/lib/VN3/Char/Edit.pm deleted file mode 100644 index e711eb17..00000000 --- a/lib/VN3/Char/Edit.pm +++ /dev/null @@ -1,168 +0,0 @@ -package VN3::Char::Edit; - -use VN3::Prelude; - - -my $FORM = { - alias => { required => 0, default => '', maxlength => 500 }, - desc => { required => 0, default => '', maxlength => 5000 }, - hidden => { anybool => 1 }, - locked => { anybool => 1 }, - original => { required => 0, default => '', maxlength => 200 }, - name => { maxlength => 200 }, - b_day => { uint => 1, range => [ 0, 31 ] }, - b_month => { uint => 1, range => [ 0, 12 ] }, - s_waist => { uint => 1, range => [ 0, 99999 ] }, - s_bust => { uint => 1, range => [ 0, 99999 ] }, - s_hip => { uint => 1, range => [ 0, 99999 ] }, - height => { uint => 1, range => [ 0, 99999 ] }, - weight => { uint => 1, range => [ 0, 99999 ], required => 0 }, - gender => { gender => 1 }, - bloodt => { blood_type => 1 }, - image => { required => 0, default => 0, id => 1 }, # X - main => { id => 1, required => 0 }, # X - main_spoil => { spoiler => 1 }, - main_name => { _when => 'out' }, - main_is => { _when => 'out', anybool => 1 }, # If true, this character is already a "main" character for other character(s) - traits => { maxlength => 200, sort_keys => 'tid', aoh => { - tid => { id => 1 }, # X - spoil => { spoiler => 1 }, - group => { _when => 'out' }, - name => { _when => 'out' }, - } }, - vns => { maxlength => 50, sort_keys => ['vid', 'rid'], aoh => { - vid => { id => 1 }, # X - rid => { id => 1, required => 0 }, # X - role => { char_role => 1 }, - spoil => { spoiler => 1 }, - title => { _when => 'out' }, - } }, - - vnrels => { _when => 'out', aoh => { - id => { id => 1 }, - releases => { aoh => { - id => { id => 1 }, - title => { }, - lang => { type => 'array', values => {} }, - } } - } }, - - id => { _when => 'out', required => 0, id => 1 }, - authmod => { _when => 'out', anybool => 1 }, - editsum => { _when => 'in out', editsum => 1 }, -}; - -my $FORM_OUT = form_compile out => $FORM; -my $FORM_IN = form_compile in => $FORM; -my $FORM_CMP = form_compile cmp => $FORM; - -elm_form CharEdit => $FORM_OUT, $FORM_IN; - - -sub vnrels { - my @vns = @_; - my $v = [ map +{ id => $_ }, @vns ]; - enrich_list releases => id => vid => sub { - sql q{SELECT rv.vid, r.id, r.title FROM releases r JOIN releases_vn rv ON rv.id = r.id WHERE NOT r.hidden AND rv.vid IN}, $_[0], q{ORDER BY r.id} - }, $v; - enrich_list1 lang => id => id => sub { sql 'SELECT id, lang FROM releases_lang WHERE id IN', $_[0], 'ORDER BY id, lang' }, map $_->{releases}, @$v; - $v -} - - -TUWF::get qr{/$CREV_RE/(?<type>edit|copy)} => sub { - my $c = entry c => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound; - return tuwf->resDenied if !can_edit c => $c; - my $copy = tuwf->capture('type') eq 'copy'; - - $c->{main_name} = $c->{main} ? tuwf->dbVali('SELECT name FROM chars WHERE id =', \$c->{main}) : ''; - $c->{main_is} = !$copy && tuwf->dbVali('SELECT 1 FROM chars WHERE main =', \$c->{id})||0; - - enrich tid => q{SELECT t.id AS tid, t.name, g.name AS group, g.order FROM traits t JOIN traits g ON g.id = t.group WHERE t.id IN} => $c->{traits}; - $c->{traits} = [ sort { $a->{order} <=> $b->{order} || $a->{name} cmp $b->{name} } @{$c->{traits}} ]; - - enrich vid => q{SELECT id AS vid, title FROM vn WHERE id IN} => $c->{vns}; - $c->{vns} = [ sort { $a->{vid} <=> $b->{vid} } @{$c->{vns}} ]; - - my %vids = map +($_->{vid}, 1), @{$c->{vns}}; - $c->{vnrels} = vnrels keys %vids; - - $c->{authmod} = auth->permDbmod; - $c->{editsum} = $copy ? "Copied from c$c->{id}.$c->{chrev}" : $c->{chrev} == $c->{maxrev} ? '' : "Reverted to revision c$c->{id}.$c->{chrev}"; - - my $title = sprintf '%s %s', $copy ? 'Copy' : 'Edit', $c->{name}; - Framework index => 0, title => $title, - top => sub { - Div class => 'col-md', sub { - EntryEdit c => $c; - Div class => 'detail-page-title', sub { - Txt $title; - Debug $c; - }; - }; - }, sub { - FullPageForm module => 'CharEdit.Main', schema => $FORM_OUT, data => { %$c, $copy ? (id => undef) : () }, sections => [ - general => 'General info', - traits => 'Traits', - vns => 'Visual novels', - ]; - }; -}; - - -TUWF::get qr{/$VID_RE/addchar}, sub { - return tuwf->resDenied if !auth->permEdit; - - my $vn = tuwf->dbRowi('SELECT id, title FROM vn WHERE NOT hidden AND id =', \tuwf->capture('id')); - return tuwf->resNotFound if !$vn->{id}; - - my $data = { - vns => [ { vid => $vn->{id}, rid => undef, role => 'primary', spoil => 0, title => $vn->{title} } ], - vnrels => vnrels $vn->{id} - }; - - Framework index => 0, title => "Add a new character to $vn->{title}", narrow => 1, sub { - FullPageForm module => 'CharEdit.New', schema => $FORM_OUT, data => $data, sections => [ - general => 'General info', - format => 'Format', - relations => 'Relations' - ]; - }; -}; - - -json_api qr{/(?:$CID_RE/edit|c/add)}, $FORM_IN, sub { - my $data = shift; - my $new = !tuwf->capture('id'); - my $c = $new ? { id => 0 } : entry c => tuwf->capture('id') or return tuwf->resNotFound; - - return $elm_Unauth->() if !can_edit c => $c; - - if(!auth->permDbmod) { - $data->{hidden} = $c->{hidden}||0; - $data->{locked} = $c->{locked}||0; - } - $data->{main} = undef if $data->{hidden}; - $data->{main_spoil} = 0 if !$data->{main}; - - die "Image not found" if $data->{image} && !-e tuwf->imgpath(ch => $data->{image}); - if($data->{main}) { - die "Relation with self" if $data->{main} == $c->{id}; - die "Invalid main" if !tuwf->dbVali('SELECT 1 FROM chars WHERE main IS NULL AND id =', \$data->{main}); - die "Main set when self is main" if $c->{id} && tuwf->dbVali('SELECT 1 FROM chars WHERE main =', \$c->{id}); - } - validate_dbid 'SELECT id FROM traits WHERE id IN', map $_->{tid}, @{$data->{traits}}; - validate_dbid 'SELECT id FROM vn WHERE id IN', map $_->{vid}, @{$data->{vns}}; - for (grep $_->{rid}, @{$data->{vns}}) { - die "Invalid release $_->{rid}" if !tuwf->dbVali('SELECT 1 FROM releases_vn WHERE', { id => $_->{rid}, vid => $_->{vid} }); - } - - $data->{desc} = bb_subst_links $data->{desc}; - - return $elm_Unchanged->() if !$new && !form_changed $FORM_CMP, $data, $c; - - my($id,undef,$rev) = update_entry c => $c->{id}, $data; - $elm_Changed->($id, $rev); -}; - -1; diff --git a/lib/VN3/Char/JS.pm b/lib/VN3/Char/JS.pm deleted file mode 100644 index eafda3ad..00000000 --- a/lib/VN3/Char/JS.pm +++ /dev/null @@ -1,55 +0,0 @@ -package VN3::Char::JS; - -use VN3::Prelude; - - -my $elm_CharResult = elm_api CharResult => { aoh => { - id => { id => 1 }, - name => {}, - original => {}, - main => { type => 'hash', required => 0, keys => { - id => { id => 1 }, - name => {}, - original => {}, - }}, -}}; - -json_api '/js/char.json', { - search => { maxlength => 500 } -}, sub { - my $q = shift->{search}; - - # XXX: This query is kinda slow - my $qs = $q =~ s/[%_]//gr; - my $r = tuwf->dbAlli( - 'SELECT c.id, c.name, c.original, c.main, c2.name AS main_name, c2.original AS main_original', - 'FROM (', - # ID search - $q =~ /^$CID_RE$/ ? ('SELECT 1, id FROM chars WHERE id =', \"$1", 'UNION ALL') : (), - # exact match - 'SELECT 2, id FROM chars WHERE lower(name) = lower(', \$q, ") OR lower(translate(original,' ', '')) = lower(", \($q =~ s/\s//gr), ')', - 'UNION ALL', - # prefix match - 'SELECT 3, id FROM chars WHERE name ILIKE', \"$qs%", ' OR original ILIKE', \"$qs%", - 'UNION ALL', - # substring match - 'SELECT 4, id FROM chars WHERE name ILIKE', \"%$qs%", ' OR original ILIKE', \"%$qs%", - ') AS ct (ord, id)', - 'JOIN chars c ON c.id = ct.id', - 'LEFT JOIN chars c2 ON c2.id = c.main', - 'WHERE NOT c.hidden', - 'GROUP BY c.id, c.name, c.original, c.main, c2.name, c2.original', - 'ORDER BY MIN(ct.ord), c.name', - 'LIMIT 20' - ); - - for (@$r) { - $_->{main} = $_->{main} ? { id => $_->{main}, name => $_->{main_name}, original => $_->{main_original} } : undef; - delete $_->{main_name}; - delete $_->{main_original}; - } - - $elm_CharResult->($r); -}; - -1; diff --git a/lib/VN3/Char/Page.pm b/lib/VN3/Char/Page.pm deleted file mode 100644 index 11939060..00000000 --- a/lib/VN3/Char/Page.pm +++ /dev/null @@ -1,330 +0,0 @@ -package VN3::Char::Page; - -use VN3::Prelude; -use List::Util 'all', 'min'; - -sub Top { - my $e = shift; - - my $img = $e->{image} && tuwf->imgurl(ch => $e->{image}); - - Div class => 'fixed-size-left-sidebar-md', sub { - Img class => 'page-header-img-mobile img img--rounded d-md-none', src => $img; - Div class => 'detail-header-image-container', sub { - Img class => 'img img--fit img--rounded elevation-1 d-none d-md-block detail-header-image', src => $img; - }; - } if $img; - - Div class => 'col-md', sub { - EntryEdit c => $e; - Div class => 'detail-page-title', sub { - Txt $e->{name}; - Txt ' '.gender_icon $e->{gender}; - Txt ' '.blood_type_display $e->{bloodt} if $e->{bloodt} ne 'unknown'; - Debug $e; - }; - Div class => 'detail-page-subtitle', $e->{original} if $e->{original}; - }; -} - - -sub Settings { - my $spoil = auth->pref('spoilers') || 0; - my $ero = auth->pref('traits_sexual'); - - Div class => 'page-inner-controls', id => 'charpage_settings', sub { - Div class => 'page-inner-controls__option dropdown', sub { - A href => 'javascript:;', class => 'link--subtle dropdown__toggle', sub { - Span class => 'page-inner-controls__option-spoil', spoil_display $spoil; - Lit ' '; - Span class => 'caret', ''; - }; - Div class => 'dropdown-menu', sub { - A class => 'dropdown-menu__item page-inner-controls__option-spoil-0', href => 'javascript:;', spoil_display 0; - A class => 'dropdown-menu__item page-inner-controls__option-spoil-1', href => 'javascript:;', spoil_display 1; - A class => 'dropdown-menu__item page-inner-controls__option-spoil-2', href => 'javascript:;', spoil_display 2; - }; - }; - Div class => 'page-inner-controls__option', sub { - Switch 'Sexual traits', $ero, 'page-inner-controls__option-ero' => 1; - }; - }; -} - - -sub Description { - my $e = shift; - - Div class => 'row', sub { - Div class => 'fixed-size-left-sidebar-md', sub { - if($e->{image}) { - # second copy of image to ensure there's enough space (uh, mkay) - Img class => 'img img--fit d-none d-md-block detail-header-image-push', src => tuwf->imgurl(ch => $e->{image}); - } else { - H3 class => 'detail-page-sidebar-section-header', 'Description'; - } - }; - Div class => 'col-md', sub { - Div class => 'description serif mb-5', sub { - P sub { Lit bb2html $e->{desc} }; - }; - }; - } if $e->{desc}; -} - - -sub DetailsTable { - my $e = shift; - - my(%groups, @groups); - for(@{$e->{traits}}) { - push @groups, $_->{gid} if !$groups{$_->{gid}}; - push @{$groups{$_->{gid}}}, $_; - } - - # TODO: This was copy-pasted from VN::Page, need to consolidate (...once we figure out how to actually display chars on the VN page) - my @list = ( - $e->{alias} ? sub { - Dt 'Aliases'; - Dd $e->{alias} =~ s/\n/, /gr; - } : (), - - defined $e->{weight} || $e->{height} || $e->{s_bust} || $e->{s_waist} || $e->{s_hip} ? sub { - Dt 'Measurements'; - Dd join ', ', - $e->{height} ? "Height: $e->{height}cm" : (), - defined $e->{weight} ? "Weight: $e->{weight}kg" : (), - $e->{s_bust} || $e->{s_waist} || $e->{s_hip} ? - sprintf 'Bust-Waist-Hips: %s-%s-%scm', $e->{s_bust}||'??', $e->{s_waist}||'??', $e->{s_hip}||'??' : (); - } : (), - - $e->{b_month} && $e->{b_day} ? sub { - Dt 'Birthday'; - Dd sprintf '%d %s', $e->{b_day}, [qw{January February March April May June July August September October November December}]->[$e->{b_month}-1]; - } : (), - - # XXX: Group visibility is determined by the same 'charpage--x' classes - # as the individual traits (group is considered 'ero' if all traits are - # ero, and the lowest trait spoiler determines group spoiler level). - # But this has an unfortunate special case that isn't handled: A trait - # with (ero && spoil>0) in a group that isn't itself (ero && spoil>0) - # will display an empty group if settings are (ero && spoil==0). - # XXX#2: I'd rather have the traits delimited by a comma, but that's a - # hard problem to solve in combination with the dynamic hiding of - # traits. - (map { my $g = $_; sub { - my @c = mkclass - 'charpage--ero' => (all { $_->{sexual} } @{$groups{$g}}), - sprintf('charpage--spoil-%d', min map $_->{spoil}, @{$groups{$g}}) => 1; - - Dt @c, sub { A href => "/i$g", $groups{$g}[0]{group} }; - Dd @c, sub { - Join ' ', sub { - A mkclass('trait-summary--trait' => 1, 'charpage--ero' => $_[0]{sexual}, sprintf('charpage--spoil-%d', $_[0]{spoil}), 1), - style => 'padding-right: 15px; white-space: nowrap', - href => "/i$_[0]{tid}", $_[0]{name} - }, @{$groups{$g}}; - }; - } } @groups), - ); - - Div class => 'row', sub { - Div class => 'fixed-size-left-sidebar-md', sub { - H2 class => 'detail-page-sidebar-section-header', 'Details'; - }; - Div class => 'col-md', sub { - Div class => 'card card--white mb-5', sub { - Div class => 'card__section fs-medium', sub { - Div class => 'row', sub { - Dl class => 'col-md dl--horizontal', sub { $_->() for @list[0..$#list/2] }; - Dl class => 'col-md dl--horizontal', sub { $_->() for @list[$#list/2+1..$#list] }; - } - } - } - } - } if @list; -} - - -sub VNs { - my $e = shift; - - # TODO: Maybe this table should be full-width? - # TODO: Improved styling of release rows - - my $rows = sub { - for my $vn (@{$e->{vns}}) { - Tr class => sprintf('charpage--spoil-%d', $vn->{spoil}), sub { - Td class => 'tabular-nums muted', sub { ReleaseDate $vn->{c_released} }; - Td sub { - A href => "/v$vn->{vid}", title => $vn->{original}||$vn->{title}, $vn->{title}; - }; - Td $vn->{releases}[0]{rid} ? '' : join ', ', map char_role_display($_->{role}), @{$vn->{releases}}; - Td sub { - Join ', ', sub { - A href => "/s$_[0]{sid}", title => $_[0]{original}||$_[0]{name}, $_[0]{name}; - Span class => 'muted', " ($_[0]{note})" if $_[0]{note}; - }, @{$vn->{seiyuu}}; - } - }; - for my $rel ($vn->{releases}[0]{rid} ? @{$vn->{releases}} : ()) { - Tr class => sprintf('charpage--spoil-%d', $rel->{spoil}), sub { - Td class => 'tabular-nums muted', $rel->{rid} ? sub { Lit ' '; ReleaseDate $rel->{released} } : ''; - Td sub { - Span class => 'muted', 'ยป '; - A href => "/r$rel->{rid}", title => $rel->{title}||$rel->{original}, $rel->{title} if $rel->{rid}; - Span class => 'muted', 'Other releases' if !$rel->{rid}; - }; - Td char_role_display $rel->{role}; - Td ''; - }; - } - } - }; - - Div class => 'row', sub { - Div class => 'fixed-size-left-sidebar-md', sub { - H2 class => 'detail-page-sidebar-section-header', 'Visual Novels'; - }; - Div class => 'col-md', sub { - Div class => 'card card--white mb-5', sub { - Table class => 'table table--responsive-single-sm fs-medium', sub { - Thead sub { - Tr sub { - Th width => '15%', 'Date'; - Th width => '40%', 'Title'; - Th width => '20%', 'Role'; - Th width => '25%', 'Voiced by'; - }; - }; - Tbody $rows; - }; - } - } - } -} - - -sub Instances { - my $e = shift; - - return if !@{$e->{instances}}; - - my $minspoil = min map $_->{spoiler}, @{$e->{instances}}; - - Div class => sprintf('row charpage--spoil-%d', $minspoil), sub { - Div class => 'fixed-size-left-sidebar-md', sub { - H2 class => 'detail-page-sidebar-section-header', 'Other instances'; - }; - Div class => 'col-md', sub { - for my $c (@{$e->{instances}}) { - A class => sprintf('card card--white character-card mb-3 charpage--spoil-%d', $c->{spoiler}), href => "/c$c->{id}", sub { - Div class => 'character-card__left', sub { - Div class => 'character-card__image-container', sub { - Img class => 'character-card__image', src => tuwf->imgurl(ch => $c->{image}) if $c->{image}; - }; - Div class => 'character-card__main', sub { - Div class => 'character-card__name', sub { - Txt $c->{name}; - Txt ' '.gender_icon $c->{gender}; - Txt ' '.blood_type_display $c->{bloodt} if $c->{bloodt} ne 'unknown'; - }; - Div class => 'character-card__sub-name', $c->{original} if $c->{original}; - Div class => 'character-card__vns muted single-line', join ', ', map $_->{title}, @{$c->{vns}} if @{$c->{vns}}; - }; - Div class => 'character-card__right serif semi-muted', sub { - Lit bb2text $c->{desc}; # TODO: maxlength? - }; - } - } - } - }; - }; -} - - -TUWF::get qr{/$CREV_RE}, sub { - my $e = entry c => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound; - return tuwf->resNotFound if !$e->{id} || $e->{hidden}; - - enrich tid => q{ - SELECT t.id AS tid, t.name, t.sexual, g.id AS gid, g.name AS group, g.order - FROM traits t - JOIN traits g ON g.id = t.group - WHERE t.id IN - }, $e->{traits}; - - $e->{traits} = [ sort { $a->{order} <=> $b->{order} || $a->{name} cmp $b->{name} } @{$e->{traits}} ]; - - $e->{vns} = tuwf->dbAlli(q{ - SELECT cv.vid, v.title, v.original, v.c_released, MIN(cv.spoil) AS spoil - FROM chars_vns_hist cv - JOIN vn v ON cv.vid = v.id - WHERE cv.chid =}, \$e->{chid}, q{ - GROUP BY v.c_released, cv.vid, v.title, v.original - ORDER BY v.c_released, cv.vid - }); - - enrich_list releases => vid => vid => sub {sql q{ - SELECT cv.rid, cv.vid, cv.role, cv.spoil, r.title, r.original, r.released - FROM chars_vns_hist cv - LEFT JOIN releases r ON r.id = cv.rid - WHERE cv.chid =}, \$e->{chid}, q{ - ORDER BY r.released, r.id - }}, $e->{vns}; - - enrich_list seiyuu => vid => vid => sub {sql q{ - SELECT vs.id AS vid, vs.note, sa.id AS sid, sa.aid, sa.name, sa.original - FROM vn_seiyuu vs - JOIN staff_alias sa ON vs.aid = sa.aid - WHERE vs.cid =}, \$e->{id}, q{ - ORDER BY sa.name, sa.aid - }}, $e->{vns}; - - $e->{instances} = tuwf->dbAlli(q{ - SELECT id, name, original, image, gender, bloodt, "desc", - (CASE WHEN id =}, \$e->{main}, THEN => \$e->{main_spoil}, q{ELSE main_spoil END) AS spoiler - FROM chars - WHERE NOT hidden - AND id <>}, \$e->{id}, q{ - AND ( main =}, \$e->{id}, q{ - OR main =}, \$e->{main}, q{ - OR id =}, \$e->{main}, q{ - ) - ORDER BY name, id - }); - enrich_list vns => id => cid => sub {sql q{ - SELECT cv.id AS cid, v.id, v.title - FROM chars_vns cv - JOIN vn v ON v.id = cv.vid - WHERE cv.id IN}, $_[0], q{ - AND cv.spoil = 0 - GROUP BY v.id, cv.id, v.title - ORDER BY MIN(cv.role), v.title, v.id - }}, $e->{instances}; - - my $spoil = auth->pref('spoilers') || 0; - my $ero = auth->pref('traits_sexual'); - - Framework - og => { - description => bb2text($e->{desc}), - $e->{image} ? (image => tuwf->imgurl(ch => $e->{image})) : () - }, - title => $e->{name}, - main_classes => { - 'charpage--hide-spoil-1' => $spoil < 1, - 'charpage--hide-spoil-2' => $spoil < 2, - 'charpage--hide-ero' => !$ero - }, - top => sub { Top $e }, - sub { - Settings $e; - Description $e; - DetailsTable $e; - VNs $e; - Instances $e; - }; -}; - -1; diff --git a/lib/VN3/DB.pm b/lib/VN3/DB.pm deleted file mode 100644 index 35b31660..00000000 --- a/lib/VN3/DB.pm +++ /dev/null @@ -1,287 +0,0 @@ -package VN3::DB; - -use v5.10; -use strict; -use warnings; -use TUWF; -use SQL::Interp ':all'; -use Carp 'carp'; -use VNWeb::DB (); # For the tuwf->dbVali etc methods -use base 'Exporter'; - -our @EXPORT = qw/ - sql - sql_join sql_comma sql_and sql_array sql_func sql_fromhex sql_tohex sql_fromtime sql_totime - enrich enrich_list enrich_list1 - entry update_entry -/; - - - -# sql_* are macros for SQL::Interp use - -# join(), but for sql objects. -sub sql_join { - my $sep = shift; - my @args = map +($sep, $_), @_; - shift @args; - return @args; -} - -# Join multiple arguments together with a comma, for use in a SELECT or IN -# clause or function arguments. -sub sql_comma { sql_join ',', @_ } - -sub sql_and { sql_join 'AND', map sql('(', $_, ')'), @_ } - -# Construct a PostgreSQL array type from the function arguments. -sub sql_array { 'ARRAY[', sql_join(',', map \$_, @_), ']' } - -# Call an SQL function -sub sql_func { - my($funcname, @args) = @_; - sql $funcname, '(', sql_comma(@args), ')'; -} - -# Convert a Perl hex value into Postgres bytea -sub sql_fromhex($) { - sql_func decode => \$_[0], "'hex'"; -} - -# Convert a Postgres bytea into a Perl hex value -sub sql_tohex($) { - sql_func encode => $_[0], "'hex'"; -} - -# Convert a Perl time value (UNIX timestamp) into a Postgres timestamp -sub sql_fromtime($) { - sql_func to_timestamp => \$_[0]; -} - -# Convert a Postgres timestamp into a Perl time value -sub sql_totime($) { - sql "extract('epoch' from ", $_[0], ')'; -} - - - -# Helper function for the enrich functions below. -sub _enrich { - my($merge, $key, $sql, @array) = @_; - - # 'flatten' the given array, so that you can also give arrayrefs as argument - @array = map +(ref $_ eq 'ARRAY' ? @$_ : $_), @array; - - # Create a list of unique identifiers to fetch, do nothing if there's nothing to fetch - my %ids = map +($_->{$key},1), @array; - return if !keys %ids; - - # Fetch the data - $sql = ref $sql eq 'CODE' ? $sql->([keys %ids]) : sql $sql, [keys %ids]; - my $data = tuwf->dbAlli($sql); - - # And merge - $merge->($data, \@array); -} - - -# This function is slightly magical: It is used to fetch information from the -# database and add it to an existing data structure. Usage: -# -# enrich $key, $sql, $object1, $object2, [$more_objects], ..; -# -# Where each $object is an hashref that will be modified in-place. $key is the -# name of a key that should be present in each $object, and indicates the value -# that should be used as database identifier to fetch more information. $sql is -# the SQL query that is used to fetch more information for each identifier. If -# $sql is a subroutine, then it is given an arrayref of keys (to be used in an -# WHERE x IN() clause), and should return a sql() query. If $sql is a string -# or sql() query itself, then the arrayref of keys is appended to it. The -# generated SQL query should return a column named $key, so that the other -# columns can be merged back into the $objects. -sub enrich { - my($key, $sql, @array) = @_; - _enrich sub { - my($data, $array) = @_; - my %ids = map +(delete($_->{$key}), $_), @$data; - # Copy the key to a temp variable to prevent stringifycation of integer keys - %$_ = (%$_, %{$ids{ (my $v = $_->{$key}) }}) for @$array; - }, $key, $sql, @array; -} - - -# Similar to enrich(), but instead of requiring a one-to-one mapping between -# $object->{$key} and the row returned by $sql, this function allows multiple -# rows to be returned by $sql. $object->{$key} is compared with $merge_col -# returned by the SQL query, the rows are stored as an arrayref in -# $object->{$name}. -sub enrich_list { - my($name, $key, $merge_col, $sql, @array) = @_; - _enrich sub { - my($data, $array) = @_; - my %ids = (); - push @{$ids{ delete $_->{$merge_col} }}, $_ for @$data; - $_->{$name} = $ids{ (my $v = $_->{$key}) }||[] for @$array; - }, $key, $sql, @array; -} - - -# Similar to enrich_list(), instead of returning each row as a hash, each row -# is taken to be a single value. -sub enrich_list1 { - my($name, $key, $merge_col, $sql, @array) = @_; - _enrich sub { - my($data, $array) = @_; - my %ids = (); - push @{$ids{ delete $_->{$merge_col} }}, values %$_ for @$data; - $_->{$name} = $ids{ (my $v = $_->{$key}) }||[] for @$array; - }, $key, $sql, @array; -} - - - - -# Database entry API: Intended to provide a low-level read/write interface for -# versioned database entires. The same data structure is used for reading and -# updating entries, and should support easy diffing/comparison. -# Probably not very convenient for general querying & searching, but we'll see. - -my %entry_prefixes = (qw{ - c chars - d docs - p producers - r releases - s staff - v vn -}); - -# Reads the database schema and creates a hash of -# 'table' => [versioned item-specific columns] -# for a particular entry prefix, where each column is a hash. -# -# These functions assume a specific table layout for versioned database -# entries, as documented in util/sql/schema.sql. -sub _entry_tables { - my $prefix = shift; - my $tables = tuwf->dbh->column_info(undef, undef, "$prefix%_hist", undef)->fetchall_arrayref({}); - my %tables; - for (@$tables) { - (my $t = $_->{TABLE_NAME}) =~ s/_hist$//; - next if $_->{COLUMN_NAME} eq 'chid'; - push @{$tables{$t}}, { - name => $_->{pg_column}, # Raw name, as it appears in the data structure - type => $_->{TYPE_NAME}, # Postgres type name - sql_ref => $_->{COLUMN_NAME}, # SQL to refer to this column - sql_read => $_->{COLUMN_NAME}, # SQL to read this column (could be used to transform the data to something perl likes) - sql_write => sub { \$_[0] }, # SQL to convert Perl data into something that can be assigned to the column - }; - } - \%tables; -} - - -sub _entry_type { - # Store the cached result of _entry_tables() for each entry type - state $types = { - map +($_, _entry_tables $entry_prefixes{$_}), - keys %entry_prefixes - }; - $types->{ shift() }; -} - - -# Returns everything for a specific entry ID. The top-level hash also includes -# the following keys: -# -# id, chid, rev, maxrev, hidden, locked, entry_hidden, entry_locked -# -# (Ordering of arrays is unspecified) -sub entry { - my($type, $id, $rev) = @_; - - my $prefix = $entry_prefixes{$type}||die; - my $t = _entry_type $type; - - my $maxrev = tuwf->dbVali('SELECT MAX(rev) FROM changes WHERE type =', \$type, ' AND itemid =', \$id); - return undef if !$maxrev; - $rev ||= $maxrev; - my $entry = tuwf->dbRowi(q{ - SELECT itemid AS id, id AS chid, rev AS chrev, ihid AS hidden, ilock AS locked - FROM changes - WHERE}, { type => $type, itemid => $id, rev => $rev } - ); - return undef if !$entry->{id}; - $entry->{maxrev} = $maxrev; - - if($maxrev == $rev) { - $entry->{entry_hidden} = $entry->{hidden}; - $entry->{entry_locked} = $entry->{locked}; - } else { - enrich id => "SELECT id, hidden AS entry_hidden, locked AS entry_locked FROM $prefix WHERE id IN", $entry; - } - - enrich chid => sql( - SELECT => sql_comma(chid => map $_->{sql_read}, @{$t->{$prefix}}), - FROM => "${prefix}_hist", - 'WHERE chid IN' - ), $entry; - - for my $tbl (grep /^${prefix}_/, keys %$t) { - (my $name = $tbl) =~ s/^${prefix}_//; - $entry->{$name} = tuwf->dbAlli( - SELECT => sql_comma(map $_->{sql_read}, @{$t->{$tbl}}), - FROM => "${tbl}_hist", - WHERE => { chid => $entry->{chid} }); - } - $entry -} - - -# Update or create an entry, usage: -# ($id, $chid, $rev) = update_entry $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 entry(), but instead with -# the following additional keys in the top-level hash: -# -# hidden, locked, editsum -sub update_entry { - my($type, $id, $data, $uid) = @_; - $id ||= undef; - - my $prefix = $entry_prefixes{$type}||die; - my $t = _entry_type $type; - - 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}, - }); - - tuwf->dbExeci("UPDATE edit_${prefix} SET ", - sql_comma(map sql($_->{sql_ref}, ' = ', $_->{sql_write}->($data->{$_->{name}})), @{$t->{$prefix}})); - - for my $tbl (grep /^${prefix}_/, keys %$t) { - (my $name = $tbl) =~ s/^${prefix}_//; - - my @rows = map { - my $d = $_; - sql '(', sql_comma(map $_->{sql_write}->($d->{$_->{name}}), @{$t->{$tbl}}), ')' - } @{$data->{$name}}; - - tuwf->dbExeci("DELETE FROM edit_${tbl}"); - tuwf->dbExeci("INSERT INTO edit_${tbl} ", - '(', sql_comma(map $_->{sql_ref}, @{$t->{$tbl}}), ')', - ' 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/VN3/Docs/Edit.pm b/lib/VN3/Docs/Edit.pm deleted file mode 100644 index a93be5b2..00000000 --- a/lib/VN3/Docs/Edit.pm +++ /dev/null @@ -1,54 +0,0 @@ -package VN3::Docs::Edit; - -use VN3::Prelude; -use VN3::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{/$DREV_RE/edit} => sub { - my $d = 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, - sub { - Div class => 'row', sub { - Div class => 'fixed-size-left-sidebar-md doc-list', \&Sidebar; - Div class => 'col-md col-md--4', sub { - Div 'data-elm-module' => 'DocEdit', - 'data-elm-flags' => JSON::XS->new->encode($FORM_OUT->analyze->coerce_for_json($d)), ''; - }; - }; - }; -}; - - -json_api qr{/$DOC_RE/edit}, $FORM_IN, sub { - my $data = shift; - my $doc = 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) = update_entry d => $doc->{id}, $data; - $elm_Changed->($id, $rev); -}; - -1; diff --git a/lib/VN3/Docs/JS.pm b/lib/VN3/Docs/JS.pm deleted file mode 100644 index 397842fd..00000000 --- a/lib/VN3/Docs/JS.pm +++ /dev/null @@ -1,15 +0,0 @@ -package Docs::JS; - -use VN3::Prelude; -use VN3::Docs::Lib; - -my $elm_Content = elm_api Content => {}; - -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/VN3/Docs/Lib.pm b/lib/VN3/Docs/Lib.pm deleted file mode 100644 index e9239499..00000000 --- a/lib/VN3/Docs/Lib.pm +++ /dev/null @@ -1,86 +0,0 @@ -package VN3::Docs::Lib; - -use VN3::Prelude; -use Text::MultiMarkdown 'markdown'; - -our @EXPORT = qw/md2html Sidebar/; - - -sub md2html { - my $content = shift; - - $content =~ s{^:MODERATORS:$}{ - my %modperms = map auth->listPerms->{$_} & auth->defaultPerms ? () : ($_, auth->listPerms->{$_}), keys %{ auth->listPerms }; - my $l = tuwf->dbAlli('SELECT id, username, perm FROM users WHERE (perm & ', \(auth->allPerms &~ auth->defaultPerms), ') > 0 ORDER BY id LIMIT 100'); - '<dl>'.join('', map { - my $u = $_; - my $p = $u->{perm} >= auth->allPerms ? 'admin' - : join ', ', sort grep $u->{perm} & $modperms{$_}, keys %modperms; - sprintf '<dt><a href="/u%d">%s</a></dt><dd>%s</dd>', $_->{id}, $_->{username}, $p; - } @$l).'</dl>'; - }me; - - my $html = markdown $content, { - strip_metadata => 1, - img_ids => 0, - disable_footnotes => 1, - disable_bibliography => 1, - }; - - # Number sections and turn them into links - my($sec, $subsec) = (0,0); - $html =~ s{<h([1-2])[^>]+>(.*?)</h\1>}{ - if($1 == 1) { - $sec++; - $subsec = 0; - qq{<h2><a href="#$sec" name="$sec">$sec. $2</a></h2>} - } elsif($1 == 2) { - $subsec++; - qq|<h3><a href="#$sec.$subsec" name="$sec.$subsec">$sec.$subsec. $2</a></h3>\n| - } - }ge; - - # Text::MultiMarkdown doesn't handle fenced code blocks properly. The - # following solution breaks inline code blocks, but I don't use those anyway. - $html =~ s/<code>/<pre>/g; - $html =~ s#</code>#</pre>#g; - - $html -} - - -sub Cat { - Div class => 'doc-list__title', $_[0]; -} - -sub Doc { - A mkclass('doc-list__doc' => 1, 'doc-list__doc--active' => tuwf->capture('id') == $_[0]), - href => "/d$_[0]", $_[1]; -} - - -sub Sidebar { - # TODO: Turn this into a nav-sidebar for better mobile viewing? - Cat 'About VNDB'; - Doc 7, 'About us'; - Doc 6, 'FAQ'; - Doc 9, 'Discussion board'; - Doc 17, 'Privacy Policy & Licensing'; - Doc 11, 'Database API'; - Doc 14, 'Database Dumps'; - Doc 18, 'Database Querying'; - Doc 8, 'Development'; - - Cat 'Guidelines'; - Doc 5, 'Editing guidelines'; - Doc 2, 'Visual novels'; - Doc 15, 'Special games'; - Doc 3, 'Releases'; - Doc 4, 'Producers'; - Doc 16, 'Staff'; - Doc 12, 'Characters'; - Doc 10, 'Tags & Traits'; - Doc 13, 'Capturing screenshots'; -} - -1; diff --git a/lib/VN3/Docs/Page.pm b/lib/VN3/Docs/Page.pm deleted file mode 100644 index 0392434b..00000000 --- a/lib/VN3/Docs/Page.pm +++ /dev/null @@ -1,23 +0,0 @@ -package VN3::Docs::Page; - -use VN3::Prelude; -use VN3::Docs::Lib; - -TUWF::get qr{/$DREV_RE} => sub { - my $d = entry d => tuwf->capture('id'), tuwf->capture('rev'); - return tuwf->resNotFound if !$d || $d->{hidden}; - - Framework title => $d->{title}, - sub { - Div class => 'row', sub { - Div class => 'fixed-size-left-sidebar-md doc-list', \&Sidebar; - Div class => 'col-md doc', sub { - EntryEdit d => $d; - H1 $d->{title}; - Lit md2html $d->{content}; - }; - }; - }; -}; - -1; diff --git a/lib/VN3/ElmGen.pm b/lib/VN3/ElmGen.pm deleted file mode 100644 index fefc154e..00000000 --- a/lib/VN3/ElmGen.pm +++ /dev/null @@ -1,197 +0,0 @@ -# This module is responsible for generating elm3/Lib/Gen.elm. Variables and -# type definitions can be added from any Perl module by calling def(), -# elm_form() and elm_api() at file load time. - -package VN3::ElmGen; - -use strict; -use warnings; -use TUWF; -use Exporter 'import'; -use List::Util 'max'; -use VNWeb::Auth; -use VN3::Types; -use VNDB::Types; - -our @EXPORT = qw/ - elm_form elm_api - $elm_Unauth $elm_Unchanged $elm_Changed $elm_Success $elm_CSRF -/; - - -my $data = <<_; --- This file is automatically generated from lib/VN3/ElmGen.pm --- DO NOT EDIT! -module Lib.Gen exposing (..) - -import Http -import Json.Encode as JE -import Json.Decode as JD - -type alias Medium = - { qty : Bool - , single : String - , plural : String - } -_ - - - -# 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; } - -# Output a variable definition: name, type, value -sub def($$$) { $data .= sprintf "\n%s : %s\n%1\$s = %s\n", @_; } - - -# Define an Elm type corresponding to a TUWF::Validate schema -sub def_type { - my($name, $obj) = @_; - my @keys = $obj->{keys} ? grep $obj->{keys}{$_}{keys}||($obj->{keys}{$_}{values}&&$obj->{keys}{$_}{values}{keys}), sort keys %{$obj->{keys}} : (); - - 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 } - ); -} - - -# Define 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.'); -} - - -# Create type definitions and a JSON encoder for a typical form. -# Usage: -# -# elm_form 'FormName', $TO_ELM_SCHEMA, $TO_SERVER_SCHEMA; -# -# That will define: -# -# type alias FormName = { .. } -# type alias FormNameSend = { .. } -# formnameSendEncode : FormNameSend -> JE.Value -# -sub elm_form { - my($name, $out, $in) = @_; - def_type $name, $out->analyze; - def_type $name.'Send', $in->analyze; - encoder lc($name).'SendEncode', $name.'Send', $in->analyze; -} - - -my %apis; - -# Define an API response. This will be added to the 'Lib.Api.Response' union type. -# Usage: -# -# # At file scope: -# my $json_generator = elm_api_response UnionName => $SCHEMA1, $SCHEMA2, ..; -# -# # Later, to actually generate a JSON response: -# $json_generator->($data1, $data2, ..); -# -# Limitation: There may be only a single $SCHEMA with an embedded {type => 'hash'}. -sub elm_api { - my($name, @schema) = @_; - @schema = map tuwf->compile($_), @schema; - $apis{$name} = \@schema; - sub { - # TODO: Validate $data? Easier to catch bugs that way - tuwf->resJSON({$name, @schema ? [map $schema[$_]->analyze->coerce_for_json($_[$_], unknown => 'reject'), 0..$#schema] : 1}) - } -} - -# Common API responses. -our $elm_Unauth = elm_api 'Unauth'; -our $elm_Unchanged = elm_api 'Unchanged'; -our $elm_Changed = elm_api 'Changed', { id => 1 }, { uint => 1 }; -our $elm_Success = elm_api 'Success'; -our $elm_CSRF = elm_api 'CSRF'; - - -sub print { - # Generate the ApiResponse type and decoder. - # - # 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 $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}) { - def_type $tname, $arg; - $def .= " $tname"; - #$dec .= $jd; - } elsif($arg->{values} && $arg->{values}{keys}) { - def_type $tname, $arg->{values}; - $def .= " (List $tname)"; - #$dec .= "(JD.list $jd)"; - } else { - $def .= ' '.$arg->elm_type(); - #$dec .= $jd; - } - #$dec .= ')'; - } - push @union, $def; - push @decode, $dec; - } - $data .= sprintf "\ntype ApiResponse\n = HTTPError Http.Error\n | %s\n", join "\n | ", @union; - $data .= sprintf "\ndecodeApiResponse : JD.Decoder ApiResponse\ndecodeApiResponse = JD.oneOf\n [ %s\n ]", join "\n , ", @decode; - - print $data; -}; - - -my $perms = VNWeb::Auth::listPerms(); - -def urlStatic => String => string tuwf->conf->{url_static}; -def userPerms => 'List (Int, String)' => list map tuple($perms->{$_}, string $_), sort keys %$perms; -def vnLengths => 'List (Int, String)' => list map tuple($_, string vn_length_display $_), keys %VN_LENGTH; -def vnRelations => 'List (String, String)' => list map tuple(string $_, string vn_relation_display $_), keys %VN_RELATION; -def producerRelations => 'List (String, String)' => list map tuple(string $_, string producer_relation_display $_), keys %PRODUCER_RELATION; -def creditType => 'List (String, String)' => list map tuple(string $_, string $CREDIT_TYPE{$_}), keys %CREDIT_TYPE; -def languages => 'List (String, String)' => list map tuple(string $_, string $LANGUAGE{$_}), sort { $LANGUAGE{$a} cmp $LANGUAGE{$b} } keys %LANGUAGE; -def platforms => 'List (String, String)' => list map tuple(string $_, string $PLATFORM{$_}), keys %PLATFORM; -def releaseTypes => 'List String' => list map string($_), release_types; -def producerTypes => 'List (String, String)' => list map tuple(string $_, string $PRODUCER_TYPE{$_}), keys %PRODUCER_TYPE; -def minAges => 'List (Int, String)' => list map tuple($_, string minage_display_full $_), keys %AGE_RATING; -def resolutions => 'List (String, String)' => list map tuple(string $_, string resolution_display_full $_), keys %RESOLUTION; -def voiced => 'List (Int, String)' => list map tuple($_, string($VOICED{$_})), keys %VOICED; -def animated => 'List (Int, String)' => list map tuple($_, string($ANIMATED{$_})), keys %ANIMATED; -def genders => 'List (String, String)' => list map tuple(string $_, string gender_display $_), keys %GENDER; -def bloodTypes => 'List (String, String)' => list map tuple(string $_, string blood_type_display $_), keys %BLOOD_TYPE; -def charRoles => 'List (String, String)' => list map tuple(string $_, string char_role_display $_), keys %CHAR_ROLE; -def vnlistStatus => 'List (Int, String)' => list map tuple($_, string $VNLIST_STATUS{$_}), keys %VNLIST_STATUS; - -def emailPattern => String => string { tuwf->compile({ email => 1 })->analyze->html5_validation() }->{pattern}; -def weburlPattern => String => string { tuwf->compile({ weburl => 1 })->analyze->html5_validation() }->{pattern}; -def vnvotePattern => String => string { tuwf->compile({ vnvote => 1 })->analyze->html5_validation() }->{pattern}; - -def media => 'List (String, Medium)' => - list map tuple( - string($_), - sprintf('{ qty = %s, single = %s, plural = %s }', bool($MEDIUM{$_}{qty}), string($MEDIUM{$_}{txt}), string($MEDIUM{$_}{plural})) - ), keys %MEDIUM; - - -1; diff --git a/lib/VN3/HTML.pm b/lib/VN3/HTML.pm deleted file mode 100644 index 0dcd7241..00000000 --- a/lib/VN3/HTML.pm +++ /dev/null @@ -1,375 +0,0 @@ -# Convention: -# All HTML-generating functions are in CamelCase -# -# TODO: HTML generation for dropdowns can be abstracted more nicely. - -package VN3::HTML; - -use strict; -use warnings; -use v5.10; -use utf8; -use List::Util 'pairs', 'max', 'sum'; -use TUWF ':Html5', 'mkclass', 'uri_escape'; -use VNWeb::Auth; -use VN3::Types; -use VN3::Validation; -use base 'Exporter'; - -our @EXPORT = qw/Framework EntryEdit Switch Debug Join FullPageForm VoteGraph ListIcon GridIcon/; - - -sub Navbar { - Div class => 'nav navbar__nav navbar__main-nav', sub { - Div class => 'nav__item navbar__menu dropdown', sub { - A href => 'javascript:;', class => 'nav__link dropdown__toggle', sub { Txt 'Database '; Span class => 'caret', '' }; - Div class => 'dropdown-menu database-menu', sub { - A class => 'dropdown-menu__item', href => '/v/all', 'Visual novels'; - A class => 'dropdown-menu__item', href => '/g', 'Tags'; - A class => 'dropdown-menu__item', href => '/c/all', 'Characters'; - A class => 'dropdown-menu__item', href => '/i', 'Traits'; - A class => 'dropdown-menu__item', href => '/p/all', 'Producers'; - A class => 'dropdown-menu__item', href => '/s/all', 'Staff'; - A class => 'dropdown-menu__item', href => '/r', 'Releases'; - }; - }; - Div class => 'nav__item navbar__menu', sub { A class => 'nav__link', href => '/d6', 'FAQ' }; - Div class => 'nav__item navbar__menu', sub { A class => 'nav__link', href => '/t', 'Forums' }; - Div class => 'nav__item navbar__menu dropdown', sub { - A href => 'javascript:;', class => 'nav__link dropdown__toggle', sub { Txt 'Contribute '; Span class => 'caret', '' }; - Div class => 'dropdown-menu', sub { - A class => 'dropdown-menu__item', href => '/hist', 'Recent changes'; - A class => 'dropdown-menu__item', href => '/v/add', 'Add Visual Novel'; - A class => 'dropdown-menu__item', href => '/p/add', 'Add Producer'; - A class => 'dropdown-menu__item', href => '/s/new', 'Add Staff'; - }; - }; - Div class => 'nav__item navbar__menu', sub { - A href => '/v/all', class => 'nav__link', sub { - Span class => 'icon-desc d-md-none', 'Search '; - Img class => 'svg-icon', src => tuwf->conf->{url_static}.'/v3/heavy/search.svg'; - }; - }; - }; - - Div class => 'nav navbar__nav', sub { - my $notifies = auth && tuwf->dbVali('SELECT count(*) FROM notifications WHERE uid =', \auth->uid, 'AND read IS NULL'); - Div class => 'nav__item navbar__menu', sub { - A href => '/'.auth->uid.'/notifies', class => 'nav__link notification-icon', sub { - Span class => 'icon-desc d-md-none', 'Notifications '; - Div class => 'icon-group', sub { - Img class => 'svg-icon', src => tuwf->conf->{url_static}.'/v3/bell.svg'; - Div class => 'notification-icon__indicator', $notifies; - }; - }; - } if $notifies; - Div class => 'nav__item navbar__menu dropdown', sub { - A href => 'javascript:;', class => 'nav__link dropdown__toggle', sub { Txt auth->username.' '; Span class => 'caret'; }; - Div class => 'dropdown-menu dropdown-menu--right', sub { - my $id = auth->uid; - A class => 'dropdown-menu__item', href => "/u$id", 'Profile'; - A class => 'dropdown-menu__item', href => "/u$id/edit", 'Settings'; - A class => 'dropdown-menu__item', href => "/u$id/list", 'List'; - A class => 'dropdown-menu__item', href => "/u$id/wish", 'Wishlist'; - A class => 'dropdown-menu__item', href => "/u$id/hist", 'Recent changes'; - A class => 'dropdown-menu__item', href => "/g/links?u=$id", 'Tags'; - Div class => 'dropdown__separator', ''; - A class => 'dropdown-menu__item', href => "/u$id/logout", 'Log out'; - }; - } if auth; - if(!auth) { - Div class => 'nav__item navbar__menu', sub { A class => 'nav__link', href => '/u/register', 'Register'; }; - Div class => 'nav__item navbar__menu', sub { A class => 'nav__link', href => '/u/login', 'Login'; }; - } - }; -} - - -sub Top { - my($opt) = @_; - Div class => 'raised-top-container', sub { - Div class => 'raised-top', sub { - Div class => 'container', sub { - Div class => 'navbar navbar--expand-md', sub { - Div class => 'navbar__logo', sub { - A href => '/', 'vndb'; - }; - A href => 'javascript:;', class => 'navbar__toggler', sub { - Div class => 'navbar__toggler-icon', ''; - }; - Div class => 'navbar__collapse', \&Navbar; - }; - Div class => 'row', $opt->{top} if $opt->{top}; - }; - }; - }; -} - - -sub Bottom { - Div class => 'col-md col-md--1', sub { - Div class => 'footer__logo', sub { - A href => '/', class => 'link-subtle', 'vndb'; - }; - }; - - state $sep = sub { Span class => 'footer__sep', sub { Lit '·'; }; }; - state $lnk = sub { A href => $_[0], class => 'link--subtle', $_[1]; }; - state $root = tuwf->root; - state $ver = `git -C "$root" describe` =~ /^(.+)$/ ? $1 : ''; - - Div class => 'col-md col-md--4', sub { - Div class => 'footer__nav', sub { - $lnk->('/d7', 'about us'); - $sep->(); - $lnk->('irc://irc.synirc.net/vndb', '#vndb'); - $sep->(); - $lnk->('mailto:contact@vndb.org', 'contact@vndb.org'); - $sep->(); - $lnk->('https://code.blicky.net/yorhel/vndb/src/branch/v3', 'source'); - $sep->(); - A href => '/v/rand', class => 'link--subtle footer__random', sub { - Txt 'random vn '; - Img class => 'svg-icon', src => tuwf->conf->{url_static}.'/v3/heavy/random.svg'; - }; - $sep->(); - Txt $ver; - }; - - my $q = tuwf->dbRow('SELECT vid, quote FROM quotes ORDER BY random() LIMIT 1'); - Div class => 'footer__quote', sub { - $lnk->('/v'.$q->{vid}, $q->{quote}); - } if $q; - }; -} - - -sub Framework { - my $body = pop; - my %opt = @_; - Html sub { - Head prefix => 'og: http://ogp.me/ns#', sub { - Meta name => 'viewport', content => 'width=device-width, initial-scale=1, shrink-to-fit=no'; - Meta name => 'csrf-token', content => auth->csrftoken; - Meta charset => 'utf-8'; - Meta name => 'robots', content => 'noindex, follow' if exists $opt{index} && !$opt{index}; - Title $opt{title} . ' | vndb'; - Link rel => 'stylesheet', href => tuwf->conf->{url_static}.'/v3/style.css'; - Link rel => 'shortcut icon', href => '/favicon.ico', type => 'image/x-icon'; - Link rel => 'search', type => 'application/opensearchdescription+xml', title => 'VNDB VN Search', href => tuwf->reqBaseURI().'/opensearch.xml'; - - # TODO: Link to RSS feeds. - - # Opengraph metadata - if($opt{og}) { - $opt{og}{site_name} ||= 'The Visual Novel Database'; - $opt{og}{type} ||= 'object'; - $opt{og}{image} ||= 'https://s.vndb.org/s/angel/bg.jpg'; # TODO: Something better - $opt{og}{url} ||= tuwf->reqURI; - $opt{og}{title} ||= $opt{title}; - Meta property => "og:$_", content => ($opt{og}{$_} =~ s/\n/ /gr) for sort keys %{$opt{og}}; - } - }; - Body sub { - Div class => 'top-bar', id => 'top', ''; - Top \%opt; - Div class => 'page-container', sub { - Div mkclass( - container => 1, - 'main-container' => 1, - 'container--narrow' => $opt{narrow}, - 'flex-center-container' => $opt{center}, - 'main-container--single-col' => $opt{single_col}, - $opt{main_classes} ? %{$opt{main_classes}} :() - ), $body; - Div class => 'container', sub { - Div class => 'footer', sub { - Div class => 'row', \&Bottom; - }; - }; - }; - Script type => 'text/javascript', src => tuwf->conf->{url_static}.'/v3/elm.js', ''; - Script type => 'text/javascript', src => tuwf->conf->{url_static}.'/v3/vndb.js', ''; - #Script type => 'text/javascript', src => tuwf->conf->{url_static}.'/v3/min.js', ''; - }; - }; - if(tuwf->debug) { - tuwf->dbCommit; # Hack to measure the commit time - - my $sql = uri_escape join "\n", map { - my($sql, $params, $time) = @$_; - sprintf " [%6.2fms] %s | %s", $time*1000, $sql, - join ', ', map "$_:".DBI::neat($params->{$_}), - sort { $a =~ /^[0-9]+$/ && $b =~ /^[0-9]+$/ ? $a <=> $b : $a cmp $b } - keys %$params; - } @{ tuwf->{_TUWF}{DB}{queries} }; - A href => 'data:text/plain,'.$sql, 'SQL'; - - my $modules = uri_escape join "\n", sort keys %INC; - A href => 'data:text/plain,'.$modules, 'Modules'; - } -} - - -sub EntryEdit { - my($type, $e) = @_; - - return if $type eq 'u' && !auth->permUsermod; - - Div class => 'dropdown pull-right', sub { - A href => 'javascript:;', class => 'btn d-block dropdown__toggle', sub { - Div class => 'opacity-muted', sub { - Img class => 'svg-icon', src => tuwf->conf->{url_static}.'/v3/edit.svg'; - Span class => 'caret', ''; - }; - }; - Div class => 'dropdown-menu dropdown-menu--right database-menu', sub { - A class => 'dropdown-menu__item', href => "/$type$e->{id}", 'Details'; - A class => 'dropdown-menu__item', href => "/$type$e->{id}/hist", 'History' if $type ne 'u'; - A class => 'dropdown-menu__item', href => "/$type$e->{id}/edit", 'Edit' if can_edit $type, $e; - A class => 'dropdown-menu__item', href => "/$type$e->{id}/add", 'Add release' if $type eq 'v' && can_edit $type, $e; - A class => 'dropdown-menu__item', href => "/$type$e->{id}/addchar",'Add character' if $type eq 'v' && can_edit $type, $e; - A class => 'dropdown-menu__item', href => "/$type$e->{id}/copy", 'Copy' if $type =~ /[cr]/ && can_edit $type, $e; - }; - } -} - - -sub Switch { - my $label = shift; - my $on = shift; - my @class = mkclass - 'switch' => 1, - 'switch--on' => $on, - @_; - - A @class, href => 'javascript:;', sub { - Div class => 'switch__label', $label; - Div class => 'switch__toggle', ''; - }; -} - - -# Throw any data structure on the page for inspection. -sub Debug { - return if !tuwf->debug; - require JSON::XS; - # This provides a nice JSON browser in FF, not sure how other browsers render it. - my $data = uri_escape(JSON::XS->new->canonical->encode($_[0])); - A style => 'margin: 0 5px', title => 'Debug', href => 'data:application/json,'.$data, ' โ '; -} - - -# Similar to join($sep, map $item->($_), @list), but works for HTML generation functions. -# Join ', ', sub { A href => '#', $_[0] }, @list; -# Join \&Br, \&Txt, @list; -sub Join { - my($sep, $item, @list) = @_; - for my $i (0..$#list) { - ref $sep ? $sep->() : Txt $sep if $i > 0; - $item->($list[$i]); - } -} - - -# Full-page form, optionally with sections. Options: -# -# module => '', # Elm module to load -# data => $form_data, -# schema => $tuwf_validate_schema, # Optional TUWF::Validate schema to use to encode the data -# sections => [ # Optional list of sections -# anchor1 => 'Section 1', -# .. -# ] -# -# If no sections are given, the parent Framework() should have narrow => 1. -sub FullPageForm { - my %o = @_; - - my $form = sub { Div - 'data-elm-module' => $o{module}, - 'data-elm-flags' => JSON::XS->new->encode($o{schema} ? $o{schema}->analyze->coerce_for_json($o{data}) : $o{data}), - '' - }; - - Div class => 'row', $o{sections} ? sub { - - Div class => 'col-md col-md--1', sub { - Div class => 'nav-sidebar nav-sidebar--expand-md', sub { - A href => 'javascript:;', class => 'nav-sidebar__selection', sub { - Txt $o{sections}[1]; - Div class => 'caret', ''; - }; - Div class => 'nav nav--vertical', sub { - my $x = 0; - for my $s (pairs @{$o{sections}}) { - Div mkclass(nav__item => 1, 'nav__item--active' => !$x++), sub { - A class => 'nav__link', href => '#'.$s->key, $s->value; - } - } - }; - } - }; - Div class => 'col-md col-md--4', $form; - } : sub { - Div class => 'col-md col-md--1', $form; - }; -} - - -sub VoteGraph { - my($type, $id) = @_; - - my %histogram = map +($_->{vote}, $_), @{ tuwf->dbAlli(q{ - SELECT (vote::numeric/10)::int AS vote, COUNT(vote) as votes, SUM(vote) AS total - FROM votes}, - $type eq 'v' ? (q{ - JOIN users ON id = uid AND NOT ign_votes - WHERE vid =}, \$id - ) : (q{ - WHERE uid =}, \$id - ), q{ - GROUP BY (vote::numeric/10)::int - })}; - - my $max = max map $_->{votes}, values %histogram; - my $count = sum map $_->{votes}, values %histogram; - my $sum = sum map $_->{total}, values %histogram; - - my $Graph = sub { - Div class => 'vote-graph', sub { - Div class => 'vote-graph__scores', sub { - Div class => 'vote-graph__score', $_ for (reverse 1..10); - }; - Div class => 'vote-graph__bars', sub { - Div class => 'vote-graph__bar', style => sprintf('width: %.2f%%', ($histogram{$_}{votes}||0)/$max*100), sub { - Div class => 'vote-graph__bar-label', $histogram{$_}{votes}||'1'; - } for (reverse 1..10); - }; - }; - Div class => 'final-text', - sprintf '%d vote%s total, average %.2f%s', - $count, $count == 1 ? '' : 's', $sum/$count/10, - $type eq 'v' ? ' ('.vote_string($sum/$count).')' : ''; - }; - return ($count, $Graph); -} - -sub ListIcon { - Lit q{<svg class="svg-icon" xmlns="http://www.w3.org/2000/svg" width="14" height="14" version="1">} - .q{<g fill="currentColor" fill-rule="nonzero">} - .q{<path d="M0 2h14v2H0zM0 6h14v2H0zM0 10h14v2H0z"/>} - .q{</g>} - .q{</svg>}; -} - - -sub GridIcon { - Lit q{<svg class="svg-icon" xmlns="http://www.w3.org/2000/svg" width="14" height="14" version="1">} - .q{<g fill="currentColor" fill-rule="nonzero">} - .q{<path d="M0 0h3v3H0zM0 5h3v3H0zM0 10h3v3H0zM5 0h3v3H5zM5 5h3v3H5zM5 10h3v3H5zM10 0h3v3h-3zM10 5h3v3h-3zM10 10h3v3h-3z"/>} - .q{</g>} - .q{</svg>}; -} - -1; diff --git a/lib/VN3/Misc/Homepage.pm b/lib/VN3/Misc/Homepage.pm deleted file mode 100644 index b9939b07..00000000 --- a/lib/VN3/Misc/Homepage.pm +++ /dev/null @@ -1,31 +0,0 @@ -package VN3::User::Login; - -use VN3::Prelude; - - -TUWF::get '/' => sub { - Framework title => 'VNDB', sub { - H1 'Hello, World!'; - P sub { - Txt 'This is the place where version 3 of '; - A href => 'https://vndb.org/', 'VNDB.org'; - Txt ' is being developed. Some random notes:'; - Ul sub { - Li 'This test site interfaces directly with the same database as the main site, which makes it easier to test all the functionality and find odd test cases.'; - Li 'This test site is very incomplete, don\'t be surprised to see 404\'s or other things that don\'t work.'; - Li 'This is a long-term project, don\'t expect this new design to replace the main site anytime soon.'; - Li sub { - Txt 'Feedback/comments/ideas or want to help out? Post in '; - A href => 'https://code.blicky.net/yorhel/vndb/issues/2', 'this issue'; - Txt ' or create a new one.'; - }; - Li sub { - Txt 'You can follow development activity on the '; - A href => 'https://code.blicky.net/yorhel/vndb/src/branch/v3', 'git repo.'; - }; - }; - }; - }; -}; - -1; diff --git a/lib/VN3/Misc/ImageUpload.pm b/lib/VN3/Misc/ImageUpload.pm deleted file mode 100644 index 76a07975..00000000 --- a/lib/VN3/Misc/ImageUpload.pm +++ /dev/null @@ -1,70 +0,0 @@ -package VN3::Misc::ImageUpload; - -use VN3::Prelude; -use Image::Magick; - - -sub save_img { - my($im, $dir, $id, $ow, $oh, $pw, $ph) = @_; - - if($pw) { - my($nw, $nh) = imgsize($ow, $oh, $pw, $ph); - if($ow != $nw || $oh != $nh) { - $im->GaussianBlur(geometry => '0.5x0.5'); - $im->Resize(width => $nw, height => $nh); - $im->UnsharpMask(radius => 0, sigma => 0.75, amount => 0.75, threshold => 0.008); - } - } - - my $fn = tuwf->imgpath($dir, $id); - $im->Write($fn); - chmod 0666, $fn; -} - -my $elm_ImgFormat = elm_api 'ImgFormat'; -my $elm_Image = elm_api 'Image', {id=>1}, {uint=>1}, {uint=>1}; # id, width, height - - -TUWF::post '/js/imageupload.json', sub { - if(!auth->csrfcheck(tuwf->reqHeader('X-CSRF-Token')||'')) { - warn "Invalid CSRF token in request"; - return $elm_CSRF->(); - } - return $elm_Unauth->() if !auth->permEdit; - - my $type = tuwf->validate(post => type => { enum => [qw/cv ch sf/] })->data; - my $imgdata = tuwf->reqUploadRaw('img'); - return $elm_ImgFormat->() if $imgdata !~ /^(\xff\xd8|\x89\x50)/; # JPG or PNG header - - my $im = Image::Magick->new; - $im->BlobToImage($imgdata); - $im->Set(magick => 'JPEG'); - $im->Set(background => '#ffffff'); - $im->Set(alpha => 'Remove'); - $im->Set(quality => 90); - my($ow, $oh) = ($im->Get('width'), $im->Get('height')); - my $id; - - - # VN cover image - if($type eq 'cv') { - $id = tuwf->dbVali("SELECT nextval('covers_seq')"); - save_img $im, cv => $id, $ow, $oh, 256, 400; - - # Screenshot - } elsif($type eq 'sf') { - $id = tuwf->dbVali('INSERT INTO screenshots', { width => $ow, height => $oh }, 'RETURNING id'); - save_img $im, sf => $id; - save_img $im, st => $id, $ow, $oh, 136, 102; - - # Character image - } elsif($type eq 'ch') { - $id = tuwf->dbVali("SELECT nextval('charimg_seq')"); - save_img $im, ch => $id, $ow, $oh, 256, 300; - } - - $elm_Image->($id, $ow, $oh); -}; - - -1; diff --git a/lib/VN3/Prelude.pm b/lib/VN3/Prelude.pm deleted file mode 100644 index a10a66ac..00000000 --- a/lib/VN3/Prelude.pm +++ /dev/null @@ -1,104 +0,0 @@ -# Importing this module is equivalent to: -# -# use strict; -# use warnings; -# use v5.10; -# use utf8; -# -# use TUWF ':Html5', 'mkclass'; -# use Exporter 'import'; -# use Time::HiRes 'time'; -# -# use VNDBUtil; -# use VNDB::Types; -# use VNWeb::Auth; -# use VN3::HTML; -# use VN3::DB; -# use VN3::Types; -# use VN3::Validation; -# use VN3::BBCode; -# use VN3::ElmGen; -# -# WARNING: This should not be used from the above modules. -# -# This module also exports a few utility functions for writing URI handlers. -package VN3::Prelude; - -use strict; -use warnings; -use utf8; -use feature ':5.10'; -use TUWF; -use VNWeb::Auth; -use VN3::ElmGen; - -sub import { - my $c = caller; - - strict->import; - warnings->import; - feature->import(':5.10'); - utf8->import; - - die $@ if !eval <<" EOM;"; - package $c; - - use TUWF ':Html5', 'mkclass'; - use Exporter 'import'; - use Time::HiRes 'time'; - - use VNDBUtil; - use VNDB::Types; - use VNWeb::Auth; - use VN3::HTML; - use VN3::DB; - use VN3::Types; - use VN3::Validation; - use VN3::BBCode; - use VN3::ElmGen; - 1; - EOM; - - no strict 'refs'; - *{$c.'::json_api'} = \&json_api; -} - - - -# 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; -# }; -my $elm_Invalid = elm_api 'Invalid', {}; -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"; - $elm_CSRF->(); - return; - } - - 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"; - $elm_Invalid->($data->err); - return; - } - - $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/VN3/Producer/Edit.pm b/lib/VN3/Producer/Edit.pm deleted file mode 100644 index 3643d771..00000000 --- a/lib/VN3/Producer/Edit.pm +++ /dev/null @@ -1,136 +0,0 @@ -package VN3::Producer::Edit; - -use VN3::Prelude; - - -my $FORM = { - alias => { required => 0, default => '', maxlength => 500 }, - desc => { required => 0, default => '', maxlength => 5000 }, - hidden => { anybool => 1 }, - l_wp => { required => 0, default => '', maxlength => 150 }, - lang => { language => 1 }, - locked => { anybool => 1 }, - original => { required => 0, default => '', maxlength => 200 }, - name => { maxlength => 200 }, - ptype => { enum => \%PRODUCER_TYPE }, # This is 'type' in the database, but renamed for Elm compat - relations => { maxlength => 50, sort_keys => 'pid', aoh => { - pid => { id => 1 }, # X - relation => { producer_relation => 1 }, - name => { _when => 'out' }, - } }, - website => { required => 0, default => '', weburl => 1 }, - - id => { _when => 'out', required => 0, id => 1 }, - authmod => { _when => 'out', anybool => 1 }, - editsum => { _when => 'in out', editsum => 1 }, -}; - -my $FORM_OUT = form_compile out => $FORM; -my $FORM_IN = form_compile in => $FORM; -my $FORM_CMP = form_compile cmp => $FORM; - -elm_form ProdEdit => $FORM_OUT, $FORM_IN; - - -TUWF::get qr{/$PREV_RE/edit} => sub { - my $p = entry p => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound; - return tuwf->resDenied if !can_edit p => $p; - - enrich pid => q{SELECT id AS pid, name FROM producers WHERE id IN} => $p->{relations}; - - $p->{l_wp} //= ''; # TODO: The DB currently uses NULL when no wp link is provided, this should be an empty string instead to be consistent with most other fields. - $p->{ptype} = delete $p->{type}; - $p->{authmod} = auth->permDbmod; - $p->{editsum} = $p->{chrev} == $p->{maxrev} ? '' : "Reverted to revision p$p->{id}.$p->{chrev}"; - - Framework index => 0, title => "Edit $p->{name}", - top => sub { - Div class => 'col-md', sub { - EntryEdit p => $p; - Div class => 'detail-page-title', sub { - Txt $p->{name}; - Debug $p; - }; - }; - }, sub { - FullPageForm module => 'ProdEdit.Main', data => $p, schema => $FORM_OUT, sections => [ - general => 'General info', - relations => 'Relations', - ]; - }; -}; - - -TUWF::get '/p/add', sub { - return tuwf->resDenied if !auth->permEdit; - Framework index => 0, title => 'Add a new producer', narrow => 1, sub { - Div class => 'row', sub { - Div class => 'col-md col-md--1', sub { Div 'data-elm-module' => 'ProdEdit.New', '' }; - }; - }; -}; - - -json_api qr{/(?:$PID_RE/edit|p/add)}, $FORM_IN, sub { - my $data = shift; - my $new = !tuwf->capture('id'); - my $p = $new ? { id => 0 } : entry p => tuwf->capture('id') or return tuwf->resNotFound; - - return $elm_Unauth->() if !can_edit p => $p; - - $data->{l_wp} ||= undef; - if(!auth->permDbmod) { - $data->{hidden} = $p->{hidden}||0; - $data->{locked} = $p->{locked}||0; - } - $data->{relations} = [] if $data->{hidden}; - - die "Relation with self" if grep $_->{pid} == $p->{id}, @{$data->{relations}}; - validate_dbid 'SELECT id FROM producers WHERE id IN', map $_->{pid}, @{$data->{relations}}; - - $data->{desc} = bb_subst_links $data->{desc}; - - $p->{ptype} = delete $p->{type}; - return $elm_Unchanged->() if !$new && !form_changed $FORM_CMP, $data, $p; - $data->{type} = delete $data->{ptype}; - - my($id,undef,$rev) = update_entry p => $p->{id}, $data; - - update_reverse($id, $rev, $p, $data); - - $elm_Changed->($id, $rev); -}; - - -sub update_reverse { - my($id, $rev, $old, $new) = @_; - - my %old = map +($_->{pid}, $_), $old->{relations} ? @{$old->{relations}} : (); - my %new = map +($_->{pid}, $_), @{$new->{relations}}; - - # Updates to be performed, pid => { pid => x, relation => y } or undef if the relation should be removed. - my %upd; - - for my $i (keys %old, keys %new) { - if($old{$i} && !$new{$i}) { - $upd{$i} = undef; - } elsif(!$old{$i} || $old{$i}{relation} ne $new{$i}{relation}) { - $upd{$i} = { - pid => $id, - relation => producer_relation_reverse($new{$i}{relation}), - }; - } - } - - for my $i (keys %upd) { - my $p = entry p => $i; - $p->{relations} = [ - $upd{$i} ? $upd{$i} : (), - grep $_->{pid} != $id, @{$p->{relations}} - ]; - $p->{editsum} = "Reverse relation update caused by revision p$id.$rev"; - update_entry p => $i, $p, 1; - } -} - -1; diff --git a/lib/VN3/Producer/JS.pm b/lib/VN3/Producer/JS.pm deleted file mode 100644 index 50161ce5..00000000 --- a/lib/VN3/Producer/JS.pm +++ /dev/null @@ -1,47 +0,0 @@ -package VN3::Producer::JS; - -use VN3::Prelude; - - -my $elm_ProducerResult = elm_api ProducerResult => { aoh => { - id => { id => 1 }, - name => {}, - original => {}, - hidden => { anybool => 1 }, -}}; - - -json_api '/js/producer.json', { - search => { type => 'array', scalar => 1, minlength => 1, values => { maxlength => 500 } }, - hidden => { anybool => 1 } -}, sub { - my $data = shift; - - my $r = tuwf->dbAlli( - 'SELECT p.id, p.name, p.original, p.hidden', - 'FROM (', (sql_join 'UNION ALL', map { - my $q = $_; - my $qs = s/[%_]//gr; - +( - # ID search - /^$PID_RE$/ ? (sql 'SELECT 1, id FROM producers WHERE id =', \"$1") : (), - # exact match - sql('SELECT 2, id FROM producers WHERE lower(name) = lower(', \$q, ") OR lower(translate(original,' ', '')) = lower(", \($q =~ s/\s//gr), ')'), - # prefix match - sql('SELECT 3, id FROM producers WHERE name ILIKE', \"$qs%", ' OR original ILIKE', \"$qs%"), - # substring match - sql('SELECT 4, id FROM producers WHERE name ILIKE', \"%$qs%", ' OR original ILIKE', \"%$qs%", ' OR alias ILIKE', \"%$qs%") - ) - } @{$data->{search}}), - ') AS pt (ord, id)', - 'JOIN producers p ON p.id = pt.id', - $data->{hidden} ? () : ('WHERE NOT p.hidden'), - 'GROUP BY p.id', - 'ORDER BY MIN(pt.ord), p.name', - 'LIMIT 20' - ); - - $elm_ProducerResult->($r); -}; - -1; diff --git a/lib/VN3/Producer/Page.pm b/lib/VN3/Producer/Page.pm deleted file mode 100644 index 89cd9dd8..00000000 --- a/lib/VN3/Producer/Page.pm +++ /dev/null @@ -1,117 +0,0 @@ -package VN3::Producer::Page; - -use VN3::Prelude; - -# TODO: Releases/VNs -# TODO: Relation graph - -sub Notes { - my $e = shift; - - Div class => 'row', sub { - Div class => 'fixed-size-left-sidebar-md', sub { - H2 class => 'detail-page-sidebar-section-header', 'Notes'; - }; - Div class => 'col-md', sub { - Div class => 'description serif mb-5', sub { - P sub { Lit bb2html $e->{desc} }; - }; - }; - } if $e->{desc}; -} - - -sub DetailsTable { - my $e = shift; - - my @links = ( - $e->{website} ? [ 'Official website', $e->{website} ] : (), - $e->{l_wp} ? [ 'Wikipedia', "https://en.wikipedia.org/wiki/$e->{l_wp}" ] : (), - ); - - my %rel; - push @{$rel{$_->{relation}}}, $_ for (sort { $a->{name} cmp $b->{name} } @{$e->{relations}}); - - my @list = ( - $e->{alias} ? sub { - Dt $e->{alias} =~ /\n/ ? 'Aliases' : 'Alias'; - Dd $e->{alias} =~ s/\n/, /gr; - } : (), - - sub { - Dt 'Type'; - Dd $PRODUCER_TYPE{$e->{type}}; - }, - - sub { - Dt 'Language'; - Dd sub { - Lang $e->{lang}; - Txt " $LANGUAGE{$e->{lang}}"; - } - }, - - @links ? sub { - Dt 'Links'; - Dd sub { - Join ', ', sub { A href => $_[0][1], rel => 'nofollow', $_[0][0] }, @links; - }; - } : (), - - (map { - my $r = $_; - sub { - Dt producer_relation_display $r; - Dd sub { - Join ', ', sub { - A href => "/p$_[0]{pid}", title => $_[0]{original}||$_[0]{name}, $_[0]{name}; - }, @{$rel{$r}} - } - } - } grep $rel{$_}, keys %PRODUCER_RELATION) - ); - - Div class => 'row', sub { - Div class => 'fixed-size-left-sidebar-md', sub { - H2 class => 'detail-page-sidebar-section-header', 'Details'; - }; - Div class => 'col-md', sub { - Div class => 'card card--white mb-5', sub { - Div class => 'card__section fs-medium', sub { - Div class => 'row', sub { - Dl class => 'col-md dl--horizontal', sub { $_->() for @list[0..$#list/2] }; - Dl class => 'col-md dl--horizontal', sub { $_->() for @list[$#list/2+1..$#list] }; - } - } - } - } - } if @list; -} - - -TUWF::get qr{/$PREV_RE}, sub { - my $e = entry p => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound; - return tuwf->resNotFound if !$e->{id} || $e->{hidden}; - - enrich pid => q{SELECT id AS pid, name, original FROM producers WHERE id IN}, $e->{relations}; - - Framework - title => $e->{name}, - top => sub { - Div class => 'col-md', sub { - EntryEdit p => $e; - Div class => 'detail-page-title', sub { - Txt $e->{name}; - Debug $e; - }; - Div class => 'detail-page-subtitle', $e->{original} if $e->{original}; - # TODO: link to discussions page. Prolly needs a TopNav - } - }, - sub { - DetailsTable $e; - Notes $e; - }; -}; - -1; diff --git a/lib/VN3/Release/Edit.pm b/lib/VN3/Release/Edit.pm deleted file mode 100644 index 030c0711..00000000 --- a/lib/VN3/Release/Edit.pm +++ /dev/null @@ -1,130 +0,0 @@ -package VN3::Release::Edit; - -use VN3::Prelude; - -my $FORM = { - hidden => { anybool => 1 }, - locked => { anybool => 1 }, - title => { maxlength => 250 }, - original => { required => 0, default => '', maxlength => 250 }, - rtype => { enum => [ release_types ] }, # This is 'type' in the database, but renamed for Elm compat - patch => { anybool => 1 }, - freeware => { anybool => 1 }, - doujin => { anybool => 1 }, - lang => { minlength => 1, sort_keys => 'lang', aoh => { lang => { language => 1 } } }, - gtin => { gtin => 1 }, - catalog => { required => 0, default => '', maxlength => 50 }, - website => { required => 0, default => '', weburl => 1 }, - released => { rdate => 1, min => 1 }, - minage => { required => 0, minage => 1 }, - uncensored => { anybool => 1 }, - notes => { required => 0, default => '', maxlength => 10240 }, - resolution => { resolution => 1 }, - voiced => { voiced => 1 }, - ani_story => { animated => 1 }, - ani_ero => { animated => 1 }, - platforms => { sort_keys => 'platform', aoh => { platform => { platform => 1 } } }, - media => { sort_keys => ['media', 'qty'], aoh => { - medium => { medium => 1 }, - qty => { uint => 1, range => [0,20] }, - } }, - vn => { length => [1,50], sort_keys => 'vid', aoh => { - vid => { id => 1 }, # X - title => { _when => 'out' }, - } }, - producers => { maxlength => 50, sort_keys => 'pid', aoh => { - pid => { id => 1 }, # X - developer => { anybool => 1 }, - publisher => { anybool => 1 }, - name => { _when => 'out' }, - } }, - - id => { _when => 'out', required => 0, id => 1 }, - authmod => { _when => 'out', anybool => 1 }, - editsum => { _when => 'in out', editsum => 1 }, -}; - -my $FORM_OUT = form_compile out => $FORM; -my $FORM_IN = form_compile in => $FORM; -my $FORM_CMP = form_compile cmp => $FORM; - -elm_form RelEdit => $FORM_OUT, $FORM_IN; - -TUWF::get qr{/$RREV_RE/(?<type>edit|copy)}, sub { - my $r = entry r => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound; - return tuwf->resDenied if !can_edit r => $r; - my $copy = tuwf->capture('type') eq 'copy'; - - enrich vid => q{SELECT id AS vid, title FROM vn WHERE id IN} => $r->{vn}; - enrich pid => q{SELECT id AS pid, name FROM producers WHERE id IN} => $r->{producers}; - - $r->{rtype} = delete $r->{type}; - $r->{authmod} = auth->permDbmod; - $r->{editsum} = $copy ? "Copied from r$r->{id}.$r->{chrev}" : $r->{chrev} == $r->{maxrev} ? '' : "Reverted to revision r$r->{id}.$r->{chrev}"; - - my $title = sprintf '%s %s', $copy ? 'Copy' : 'Edit', $r->{title}; - Framework title => $title, - top => sub { - Div class => 'col-md', sub { - EntryEdit r => $r; - Div class => 'detail-page-title', sub { - Txt $title; - Debug $r; - }; - }; - }, sub { - FullPageForm module => 'RelEdit.Main', schema => $FORM_OUT, data => { %$r, $copy ? (id => undef) : () }, sections => [ - general => 'General info', - format => 'Format', - relations => 'Relations' - ]; - }; -}; - - -TUWF::get qr{/$VID_RE/add}, sub { - return tuwf->resDenied if !auth->permEdit; - - my $vn = tuwf->dbRowi('SELECT id, title, original FROM vn WHERE NOT hidden AND id =', \tuwf->capture('id')); - return tuwf->resNotFound if !$vn->{id}; - - Framework index => 0, title => "Add a new release to $vn->{title}", narrow => 1, sub { - FullPageForm module => 'RelEdit.New', data => $vn, sections => [ - general => 'General info', - format => 'Format', - relations => 'Relations' - ]; - }; -}; - - -json_api qr{/(?:$RID_RE/edit|r/add)}, $FORM_IN, sub { - my $data = shift; - my $new = !tuwf->capture('id'); - my $rel = $new ? { id => 0 } : entry r => tuwf->capture('id') or return tuwf->resNotFound; - - return $elm_Unauth->() if !can_edit r => $rel; - - if(!auth->permDbmod) { - $data->{hidden} = $rel->{hidden}||0; - $data->{locked} = $rel->{locked}||0; - } - $data->{doujin} = $data->{voiced} = $data->{ani_story} = $data->{ani_ero} = 0 if $data->{patch}; - $data->{resolution} = 'unknown' if $data->{patch}; - $data->{uncensored} = 0 if !$data->{minage} || $data->{minage} != 18; - $_->{qty} = $MEDIUM{$_->{medium}}{qty} ? $_->{qty}||1 : 0 for @{$data->{media}}; - - validate_dbid 'SELECT id FROM vn WHERE id IN', map $_->{vid}, @{$data->{vn}}; - validate_dbid 'SELECT id FROM producers WHERE id IN', map $_->{pid}, @{$data->{producers}}; - - $data->{notes} = bb_subst_links $data->{notes}; - - $rel->{rtype} = delete $rel->{type}; - return $elm_Unchanged() if !$new && !form_changed $FORM_CMP, $data, $rel; - $data->{type} = delete $data->{rtype}; - - my($id,undef,$rev) = update_entry r => $rel->{id}, $data; - $elm_Changed->($id, $rev); -}; - -1; diff --git a/lib/VN3/Release/JS.pm b/lib/VN3/Release/JS.pm deleted file mode 100644 index 152fd69a..00000000 --- a/lib/VN3/Release/JS.pm +++ /dev/null @@ -1,32 +0,0 @@ -package VN3::Release::JS; - -use VN3::Prelude; - - -my $elm_ReleaseResult = elm_api ReleaseResult => { aoh => { - id => { id => 1 }, - title => {}, - lang => { type => 'array', values => {} }, -}}; - - -# Fetch all releases assigned to a VN -json_api '/js/release.json', { - vid => { id => 1 }, -}, sub { - my $vid = shift->{vid}; - - my $r = tuwf->dbAlli(q{ - SELECT r.id, r.title - FROM releases r - JOIN releases_vn rv ON rv.id = r.id - WHERE NOT r.hidden - AND rv.vid =}, \$vid, q{ - ORDER BY r.id - }); - enrich_list1 lang => id => id => sub { sql 'SELECT id, lang FROM releases_lang WHERE id IN', $_[0], 'ORDER BY id, lang' }, $r; - - $elm_ReleaseResult->($r); -}; - -1; diff --git a/lib/VN3/Release/Page.pm b/lib/VN3/Release/Page.pm deleted file mode 100644 index 03d3bd5c..00000000 --- a/lib/VN3/Release/Page.pm +++ /dev/null @@ -1,184 +0,0 @@ -package VN3::Release::Page; - -use VN3::Prelude; - -# TODO: Userlist options - - -sub Notes { - my $e = shift; - - Div class => 'row', sub { - Div class => 'fixed-size-left-sidebar-md', sub { - H2 class => 'detail-page-sidebar-section-header', 'Notes'; - }; - Div class => 'col-md', sub { - Div class => 'description serif mb-5', sub { - P sub { Lit bb2html $e->{notes} }; - }; - }; - } if $e->{notes}; -} - - -sub DetailsTable { - my $e = shift; - - # TODO: Some of these properties could be moved into the title header thing - # (type and languages, in particular) - # (Not even sure this table format makes sense for all properties, there's gotta be a nicer way) - my @list = ( - @{$e->{vn}} ? sub { - Dt @{$e->{vn}} == 1 ? 'Visual Novel' : 'Visual Novels'; - Dd sub { - Join \&Br, sub { - A href => "/v$_[0]{vid}", title => $_[0]{original}||$_[0]{title}, $_[0]{title}; - }, @{$e->{vn}}; - } - } : (), - - sub { - Dt 'Type'; - Dd sub { - Txt ucfirst $e->{type}; - Txt ", patch" if $e->{patch}; - } - }, - - sub { - Dt 'Released'; - Dd sub { ReleaseDate $e->{released} }; - }, - - sub { - Dt @{$e->{lang}} > 1 ? 'Languages' : 'Language'; - Dd sub { - Join \&Br, sub { - Lang $_[0]{lang}; - Txt " $LANGUAGE{$_[0]{lang}}"; - }, @{$e->{lang}}; - } - }, - - sub { - Dt 'Publication'; - Dd join ', ', - $e->{freeware} ? 'Freeware' : 'Non-free', - $e->{patch} ? () : ($e->{doujin} ? 'doujin' : 'commercial') - }, - - $e->{minage} && $e->{minage} >= 0 ? sub { - Dt 'Age rating'; - Dd minage_display $e->{minage}; - } : (), - - @{$e->{platforms}} ? sub { - Dt @{$e->{platforms}} == 1 ? 'Platform' : 'Platforms'; - Dd sub { - Join \&Br, sub { - Platform $_[0]{platform}; - Txt " $PLATFORM{$_[0]{platform}}"; - }, @{$e->{platforms}}; - } - } : (), - - @{$e->{media}} ? sub { - Dt @{$e->{media}} == 1 ? 'Medium' : 'Media'; - Dd join ', ', map media_display($_->{medium}, $_->{qty}), @{$e->{media}}; - } : (), - - $e->{voiced} ? sub { - Dt 'Voiced'; - Dd $VOICED{$e->{voiced}}{txt}; - } : (), - - $e->{ani_story} ? sub { - Dt 'Story animation'; - Dd $ANIMATED{$e->{ani_story}}{txt}; - } : (), - - $e->{ani_ero} ? sub { - Dt 'Ero animation'; - Dd $ANIMATED{$e->{ani_ero}}{txt}; - } : (), - - $e->{minage} && $e->{minage} == 18 ? sub { - Dt 'Censoring'; - Dd $e->{uncensored} ? 'No optical censoring (e.g. mosaics)' : 'May include optical censoring (e.g. mosaics)'; - } : (), - - $e->{gtin} ? sub { - Dt gtintype($e->{gtin}) || 'GTIN'; - Dd $e->{gtin}; - } : (), - - $e->{catalog} ? sub { - Dt 'Catalog no.'; - Dd $e->{catalog}; - } : (), - - (map { - my $type = $_; - my @prod = grep $_->{$type}, @{$e->{producers}}; - @prod ? sub { - Dt ucfirst($type) . (@prod == 1 ? '' : 's'); - Dd sub { - Join \&Br, sub { - A href => "/p$_[0]{pid}", title => $_[0]{original}||$_[0]{name}, $_[0]{name}; - }, @prod; - } - } : () - } 'developer', 'publisher'), - - $e->{website} ? sub { - Dt 'Links'; - Dd sub { - A href => $e->{website}, rel => 'nofollow', 'Official website'; - }; - } : (), - ); - - Div class => 'row', sub { - Div class => 'fixed-size-left-sidebar-md', sub { - H2 class => 'detail-page-sidebar-section-header', 'Details'; - }; - Div class => 'col-md', sub { - Div class => 'card card--white mb-5', sub { - Div class => 'card__section fs-medium', sub { - Div class => 'row', sub { - Dl class => 'col-md dl--horizontal', sub { $_->() for @list[0..$#list/2] }; - Dl class => 'col-md dl--horizontal', sub { $_->() for @list[$#list/2+1..$#list] }; - } - } - } - } - } if @list; -} - - -TUWF::get qr{/$RREV_RE}, sub { - my $e = entry r => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound; - return tuwf->resNotFound if !$e->{id} || $e->{hidden}; - - enrich vid => q{SELECT id AS vid, title, original FROM vn WHERE id IN}, $e->{vn}; - enrich pid => q{SELECT id AS pid, name, original FROM producers WHERE id IN}, $e->{producers}; - - Framework - title => $e->{title}, - top => sub { - Div class => 'col-md', sub { - EntryEdit r => $e; - Div class => 'detail-page-title', sub { - Txt $e->{title}; - Debug $e; - }; - Div class => 'detail-page-subtitle', $e->{original} if $e->{original}; - } - }, - sub { - DetailsTable $e; - Notes $e; - }; -}; - -1; diff --git a/lib/VN3/Staff/Edit.pm b/lib/VN3/Staff/Edit.pm deleted file mode 100644 index 0b9c3af4..00000000 --- a/lib/VN3/Staff/Edit.pm +++ /dev/null @@ -1,108 +0,0 @@ -package VN3::Staff::Edit; - -use VN3::Prelude; - - -my $FORM = { - aid => { int => 1, range => [ -1000, 1<<40 ] }, # X - alias => { maxlength => 100, sort_keys => 'aid', aoh => { - aid => { int => 1, range => [ -1000, 1<<40 ] }, # X, negative IDs are for new aliases - name => { maxlength => 200 }, - original => { maxlength => 200, required => 0, default => '' }, - inuse => { anybool => 1, _when => 'out' }, - } }, - desc => { required => 0, default => '', maxlength => 5000 }, - gender => { gender => 1 }, - hidden => { anybool => 1 }, - l_site => { required => 0, default => '', weburl => 1 }, - l_wp => { required => 0, default => '', maxlength => 150 }, - l_twitter => { required => 0, default => '', maxlength => 150 }, - l_anidb => { required => 0, id => 1 }, - lang => { language => 1 }, - locked => { anybool => 1 }, - - id => { _when => 'out', required => 0, id => 1 }, - authmod => { _when => 'out', anybool => 1 }, - editsum => { _when => 'in out', editsum => 1 }, -}; - -my $FORM_OUT = form_compile out => $FORM; -my $FORM_IN = form_compile in => $FORM; -my $FORM_CMP = form_compile cmp => $FORM; - -elm_form StaffEdit => $FORM_OUT, $FORM_IN; - - -TUWF::get qr{/$SREV_RE/edit} => sub { - my $e = entry s => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound; - return tuwf->resDenied if !can_edit s => $e; - - $e->{authmod} = auth->permDbmod; - $e->{editsum} = $e->{chrev} == $e->{maxrev} ? '' : "Reverted to revision s$e->{id}.$e->{chrev}"; - - enrich aid => sub { sql ' - SELECT aid, EXISTS(SELECT 1 FROM vn_staff WHERE aid = x.aid UNION ALL SELECT 1 FROM vn_seiyuu WHERE aid = x.aid) AS inuse - FROM unnest(', sql_array(@{$_[0]}), '::int[]) AS x(aid)' - }, $e->{alias}; - - my $name = (grep $_->{aid} == $e->{aid}, @{$e->{alias}})[0]{name}; - Framework index => 0, narrow => 1, title => "Edit $name", - top => sub { - Div class => 'col-md', sub { - EntryEdit s => $e; - Div class => 'detail-page-title', sub { - Txt $name, - Debug $e; - }; - }; - }, sub { - FullPageForm module => 'StaffEdit.Main', data => $e, schema => $FORM_OUT; - }; -}; - - -TUWF::get '/s/new', sub { - return tuwf->resDenied if !auth->permEdit; - Framework index => 0, title => 'Add a new staff entry', narrow => 1, sub { - Div class => 'row', sub { - Div class => 'col-md col-md--1', sub { Div 'data-elm-module' => 'StaffEdit.New', '' }; - }; - }; -}; - - -json_api qr{/(?:$SID_RE/edit|s/add)}, $FORM_IN, sub { - my $data = shift; - my $new = !tuwf->capture('id'); - my $e = $new ? { id => 0 } : entry s => tuwf->capture('id') or return tuwf->resNotFound; - - return $elm_Unauth->() if !can_edit s => $e; - - if(!auth->permDbmod) { - $data->{hidden} = $e->{hidden}||0; - $data->{locked} = $e->{locked}||0; - } - - # For positive alias IDs: Make sure they exist and are owned by this entry. - validate_dbid - sub { sql 'SELECT aid FROM staff_alias WHERE id =', \$e->{id}, ' AND aid IN', $_[0] }, - grep $_>=0, map $_->{aid}, @{$data->{alias}}; - - # For negative alias IDs: Assign a new ID. - for my $alias (@{$data->{alias}}) { - if($alias->{aid} < 0) { - my $new = tuwf->dbVali(select => sql_func nextval => \'staff_alias_aid_seq'); - $data->{aid} = $new if $alias->{aid} == $data->{aid}; - $alias->{aid} = $new; - } - } - # We rely on Postgres to throw an error if we attempt to delete an alias that is still being referenced. - - $data->{desc} = bb_subst_links $data->{desc}; - - return $elm_Unchanged->() if !$new && !form_changed $FORM_CMP, $data, $e; - my($id,undef,$rev) = update_entry s => $e->{id}, $data; - $elm_Changed->($id, $rev); -}; - -1; diff --git a/lib/VN3/Staff/JS.pm b/lib/VN3/Staff/JS.pm deleted file mode 100644 index 58ce947b..00000000 --- a/lib/VN3/Staff/JS.pm +++ /dev/null @@ -1,43 +0,0 @@ -package Staff::JS; - -use VN3::Prelude; - -my $elm_StaffResult = elm_api StaffResult => { aoh => { - id => { id => 1 }, - aid => { id => 1 }, - name => {}, - original => {}, -}}; - -json_api '/js/staff.json', { - search => { maxlength => 500 } -}, sub { - my $q = shift->{search}; - - # XXX: This query is kinda slow - my $qs = $q =~ s/[%_]//gr; - my $r = tuwf->dbAlli( - 'SELECT s.id, st.aid, st.name, st.original', - 'FROM (', - # ID search - $q =~ /^$SID_RE$/ ? ('SELECT 1, id, aid, name, original FROM staff_alias WHERE id =', \"$1", 'UNION ALL') : (), - # exact match - 'SELECT 2, id, aid, name, original FROM staff_alias WHERE lower(name) = lower(', \$q, ") OR lower(translate(original,' ', '')) = lower(", \($q =~ s/\s//gr), ')', - 'UNION ALL', - # prefix match - 'SELECT 3, id, aid, name, original FROM staff_alias WHERE name ILIKE', \"$qs%", ' OR original ILIKE', \"$qs%", - 'UNION ALL', - # substring match - 'SELECT 4, id, aid, name, original FROM staff_alias WHERE name ILIKE', \"%$qs%", ' OR original ILIKE', \"%$qs%", - ') AS st (ord, id, aid, name, original)', - 'JOIN staff s ON s.id = st.id', - 'WHERE NOT s.hidden', - 'GROUP BY s.id, st.aid, st.name, st.original', - 'ORDER BY MIN(st.ord), st.name', - 'LIMIT 20' - ); - - $elm_StaffResult->($r); -}; - -1; diff --git a/lib/VN3/Staff/Page.pm b/lib/VN3/Staff/Page.pm deleted file mode 100644 index 2d8cd349..00000000 --- a/lib/VN3/Staff/Page.pm +++ /dev/null @@ -1,213 +0,0 @@ -package VN3::Staff::Page; - -use VN3::Prelude; - -sub Notes { - my $e = shift; - - Div class => 'row', sub { - Div class => 'fixed-size-left-sidebar-md', sub { - H2 class => 'detail-page-sidebar-section-header', 'Notes'; - }; - Div class => 'col-md', sub { - Div class => 'description serif mb-5', sub { - P sub { Lit bb2html $e->{desc} }; - }; - }; - } if $e->{desc}; -} - - -sub DetailsTable { - my $e = shift; - - my @links = ( - $e->{l_site} ? [ 'Official website', $e->{l_site} ] : (), - $e->{l_wp} ? [ 'Wikipedia', "https://en.wikipedia.org/wiki/$e->{l_wp}" ] : (), - $e->{l_twitter} ? [ 'Twitter', "https://twitter.com/$e->{l_twitter}" ] : (), - $e->{l_anidb} ? [ 'AniDB', "http://anidb.net/cr$e->{l_anidb}" ] : (), - ); - my @alias = grep $_->{aid} != $e->{aid}, @{$e->{alias}}; - - my @list = ( - @alias ? sub { - Dt @alias > 1 ? 'Aliases' : 'Alias'; - Dd sub { - Join \&Br, sub { - Txt $_[0]{name}; - Txt " ($_[0]{original})" if $_[0]{original}; - }, sort { $a->{name} cmp $b->{name} || $a->{original} cmp $b->{original} } @alias; - } - } : (), - - sub { - Dt 'Language'; - Dd sub { - Lang $e->{lang}; - Txt " $LANGUAGE{$e->{lang}}"; - } - }, - - @links ? sub { - Dt 'Links'; - Dd sub { - Join ', ', sub { A href => $_[0][1], rel => 'nofollow', $_[0][0] }, @links; - }; - } : (), - ); - - Div class => 'row', sub { - Div class => 'fixed-size-left-sidebar-md', sub { - H2 class => 'detail-page-sidebar-section-header', 'Details'; - }; - Div class => 'col-md', sub { - Div class => 'card card--white mb-5', sub { - Div class => 'card__section fs-medium', sub { - Div class => 'row', sub { - Dl class => 'col-md dl--horizontal', sub { $_->() for @list[0..$#list/2] }; - Dl class => 'col-md dl--horizontal', sub { $_->() for @list[$#list/2+1..$#list] }; - } - } - } - } - } if @list; -} - - -sub Roles { - my $e = shift; - - my $roles = tuwf->dbAlli(q{ - SELECT sa.id, sa.aid, v.id AS vid, sa.name, sa.original, v.c_released, v.title, v.original AS t_original, vs.role, vs.note - FROM vn_staff vs - JOIN vn v ON v.id = vs.id - JOIN staff_alias sa ON vs.aid = sa.aid - WHERE sa.id =}, \$e->{id}, q{ AND NOT v.hidden - ORDER BY v.c_released ASC, v.title ASC, vs.role ASC - }); - return if !@$roles; - - my $rows = sub { - for my $r (@$roles) { - Tr sub { - Td class => 'tabular-nums muted', sub { ReleaseDate $r->{c_released} }; - Td sub { - A href => "/v$r->{vid}", title => $r->{t_original}||$r->{title}, $r->{title}; - }; - Td $CREDIT_TYPE{$r->{role}}; - Td title => $r->{original}||$r->{name}, $r->{name}; - Td $r->{note}; - }; - } - }; - - # TODO: Full-width table? It's pretty dense - Div class => 'row', sub { - Div class => 'fixed-size-left-sidebar-md', sub { - H2 class => 'detail-page-sidebar-section-header', 'Credits'; - Debug $roles; - }; - Div class => 'col-md', sub { - Div class => 'card card--white mb-5', sub { - Table class => 'table table--responsive-single-sm fs-medium', sub { - Thead sub { - Tr sub { - Th width => '15%', 'Date'; - Th width => '30%', 'Title'; - Th width => '20%', 'Role'; - Th width => '20%', 'As'; - Th width => '15%', 'Note'; - }; - }; - Tbody $rows; - }; - } - } - } -} - - -sub Cast { - my $e = shift; - - my $cast = tuwf->dbAlli(q{ - SELECT sa.id, sa.aid, v.id AS vid, sa.name, sa.original, v.c_released, v.title, v.original AS t_original, c.id AS cid, c.name AS c_name, c.original AS c_original, vs.note - FROM vn_seiyuu vs - JOIN vn v ON v.id = vs.id - JOIN chars c ON c.id = vs.cid - JOIN staff_alias sa ON vs.aid = sa.aid - WHERE sa.id =}, \$e->{id}, q{ AND NOT v.hidden - ORDER BY v.c_released ASC, v.title ASC - }); - return if !@$cast; - - my $rows = sub { - for my $c (@$cast) { - Tr sub { - Td class => 'tabular-nums muted', sub { ReleaseDate $c->{c_released} }; - Td sub { - A href => "/v$c->{vid}", title => $c->{t_original}||$c->{title}, $c->{title}; - }; - Td sub { - A href => "/c$c->{cid}", title => $c->{c_original}||$c->{c_name}, $c->{c_name}; - }; - Td title => $c->{original}||$c->{name}, $c->{name}; - Td $c->{note}; - }; - } - }; - - # TODO: Full-width table? It's pretty dense - Div class => 'row', sub { - Div class => 'fixed-size-left-sidebar-md', sub { - H2 class => 'detail-page-sidebar-section-header', 'Voiced Characters'; - Debug $cast; - }; - Div class => 'col-md', sub { - Div class => 'card card--white mb-5', sub { - Table class => 'table table--responsive-single-sm fs-medium', sub { - Thead sub { - Tr sub { - Th width => '15%', 'Date'; - Th width => '30%', 'Title'; - Th width => '20%', 'Cast'; - Th width => '20%', 'As'; - Th width => '15%', 'Note'; - }; - }; - Tbody $rows; - }; - } - } - } -} - - -TUWF::get qr{/$SREV_RE}, sub { - my $e = entry s => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound; - return tuwf->resNotFound if !$e->{id} || $e->{hidden}; - - ($e->{name}, $e->{original}) = @{(grep $_->{aid} == $e->{aid}, @{$e->{alias}})[0]}{'name', 'original'}; - - Framework - title => $e->{name}, - top => sub { - Div class => 'col-md', sub { - EntryEdit s => $e; - Div class => 'detail-page-title', sub { - Txt $e->{name}; - Txt ' '.gender_icon $e->{gender}; - Debug $e; - }; - Div class => 'detail-page-subtitle', $e->{original} if $e->{original}; - } - }, - sub { - DetailsTable $e; - Notes $e; - Roles $e; - Cast $e; - }; -}; - -1; diff --git a/lib/VN3/Trait/JS.pm b/lib/VN3/Trait/JS.pm deleted file mode 100644 index 05e1d03d..00000000 --- a/lib/VN3/Trait/JS.pm +++ /dev/null @@ -1,44 +0,0 @@ -package VN3::Trait::JS; - -use VN3::Prelude; - -my $elm_TraitResult = elm_api TraitResult => { aoh => { - id => { id => 1 }, - name => {}, - gid => { id => 1, required => 0 }, - group => { required => 0 } -}}; - -# Returns only approved and applicable traits -json_api '/js/trait.json', { - search => { maxlength => 500 } -}, sub { - my $q = shift->{search}; - - my $qs = $q =~ s/[%_]//gr; - my $r = tuwf->dbAlli( - 'SELECT t.id, t.name, g.id AS gid, g.name AS group', - 'FROM (', - # ID search - $q =~ /^$IID_RE$/ ? ('SELECT 1, id FROM traits WHERE id =', \"$1", 'UNION ALL') : (), - # exact match - 'SELECT 2, id FROM traits WHERE lower(name) = lower(', \$q, ")", - 'UNION ALL', - # prefix match - 'SELECT 3, id FROM traits WHERE name ILIKE', \"$qs%", - 'UNION ALL', - # substring match + alias search - 'SELECT 4, id FROM traits WHERE name ILIKE', \"%$qs%", ' OR alias ILIKE', \"%$qs%", - ') AS tt (ord, id)', - 'JOIN traits t ON t.id = tt.id', - 'LEFT JOIN traits g ON g.id = t.group', - 'WHERE t.state = 2 AND t.applicable', - 'GROUP BY t.id, t.name, g.id, g.name', - 'ORDER BY MIN(tt.ord), t.name', - 'LIMIT 20' - ); - - $elm_TraitResult->($r); -}; - -1; diff --git a/lib/VN3/Types.pm b/lib/VN3/Types.pm deleted file mode 100644 index 273f8b79..00000000 --- a/lib/VN3/Types.pm +++ /dev/null @@ -1,171 +0,0 @@ -# Listings and formatting functions for various data types in the database. - -package VN3::Types; - -use strict; -use warnings; -use utf8; -use TUWF ':Html5'; -use POSIX 'strftime', 'ceil'; -use Exporter 'import'; -use VNDB::Types; - -our @EXPORT = qw/ - $UID_RE $VID_RE $RID_RE $SID_RE $CID_RE $PID_RE $IID_RE $DOC_RE - $VREV_RE $RREV_RE $PREV_RE $SREV_RE $CREV_RE $DREV_RE - Lang - Platform - media_display - ReleaseDate - vn_length_time vn_length_display - char_roles char_role_display - vote_display vote_string - date_display - vn_relation_reverse vn_relation_display - producer_relation_reverse producer_relation_display - spoil_display - release_types - minage_display minage_display_full - resolution_display_full - gender_display gender_icon - blood_type_display -/; - - -# Regular expressions for use in path registration -my $num = qr{[1-9][0-9]{0,6}}; -our $UID_RE = qr{u(?<id>$num)}; -our $VID_RE = qr{v(?<id>$num)}; -our $RID_RE = qr{r(?<id>$num)}; -our $SID_RE = qr{s(?<id>$num)}; -our $CID_RE = qr{c(?<id>$num)}; -our $PID_RE = qr{p(?<id>$num)}; -our $IID_RE = qr{i(?<id>$num)}; -our $DOC_RE = qr{d(?<id>$num)}; -our $VREV_RE = qr{$VID_RE(?:\.(?<rev>$num))?}; -our $RREV_RE = qr{$RID_RE(?:\.(?<rev>$num))?}; -our $PREV_RE = qr{$PID_RE(?:\.(?<rev>$num))?}; -our $SREV_RE = qr{$SID_RE(?:\.(?<rev>$num))?}; -our $CREV_RE = qr{$CID_RE(?:\.(?<rev>$num))?}; -our $DREV_RE = qr{$DOC_RE(?:\.(?<rev>$num))?}; - - -sub Lang { - Span class => 'lang-badge', uc $_[0]; -} - - - -sub Platform { - # TODO: Icons - Img class => 'svg-icon', src => tuwf->conf->{url_static}.'/v3/windows.svg', title => $PLATFORM{$_[0]}; -} - - -sub media_display { - my($media, $qty) = @_; - my $med = $MEDIUM{$media}; - return $med->{txt} if !$med->{qty}; - sprintf '%d %s', $qty, $qty == 1 ? $med->{txt} : $med->{plural}; -} - - - - -sub ReleaseDate { - my $date = sprintf '%08d', shift||0; - my $future = $date > strftime '%Y%m%d', gmtime; - my($y, $m, $d) = ($1, $2, $3) if $date =~ /^([0-9]{4})([0-9]{2})([0-9]{2})$/; - - my $str = $y == 0 ? 'unknown' : $y == 9999 ? 'TBA' : - $m == 99 ? sprintf('%04d', $y) : - $d == 99 ? sprintf('%04d-%02d', $y, $m) : - sprintf('%04d-%02d-%02d', $y, $m, $d); - - Txt $str if !$future; - B class => 'future', $str if $future; -} - - -sub vn_length_time { - my $l = $VN_LENGTH{$_[0]}; - $l->{time} || $l->{txt}; -} - -sub vn_length_display { - my $l = $VN_LENGTH{$_[0]}; - $l->{txt}.($l->{time} ? " ($l->{time})" : '') -} - - - -sub char_role_display { - my($role, $num) = @_; - $CHAR_ROLE{$role}{!$num || $num == 1 ? 'txt' : 'plural'}; -} - - - -sub vote_display { - !$_[0] ? '-' : $_[0] % 10 == 0 ? $_[0]/10 : sprintf '%.1f', $_[0]/10; -} - -sub vote_string { - ['worst ever', - 'awful', - 'bad', - 'weak', - 'so-so', - 'decent', - 'good', - 'very good', - 'excellent', - 'masterpiece']->[ceil(shift()/10)-2]; -} - - - -sub date_display { - strftime '%Y-%m-%d', gmtime $_[0]; -} - - - -sub vn_relation_reverse { $VN_RELATION{$_[0]}{reverse} } -sub vn_relation_display { $VN_RELATION{$_[0]}{txt} } - - - -sub producer_relation_reverse { $PRODUCER_RELATION{$_[0]}{reverse} } -sub producer_relation_display { $PRODUCER_RELATION{$_[0]}{txt} } - - - -sub spoil_display { - ['No spoilers' - ,'Minor spoilers' - ,'Spoil me!']->[$_[0]]; -} - - - -sub release_types { keys %RELEASE_TYPE } - - -sub minage_display { $AGE_RATING{$_[0]}{txt} } -sub minage_display_full { my $e = $AGE_RATING{$_[0]}; $e->{txt}.($e->{ex} ? " (e.g. $e->{ex})" : '') }; - - - -sub resolution_display_full { my $e = $RESOLUTION{$_[0]}; ($e->{cat} ? ucfirst "$e->{cat}: " : '').$e->{txt} } - - -sub gender_display { $GENDER{$_[0]} } -sub gender_icon { +{qw/m โ f โ mf โโ/}->{$_[0]}||'' } - - - -sub blood_type_display { $BLOOD_TYPE{$_[0]} } - - -1; diff --git a/lib/VN3/User/Lib.pm b/lib/VN3/User/Lib.pm deleted file mode 100644 index c63e4286..00000000 --- a/lib/VN3/User/Lib.pm +++ /dev/null @@ -1,31 +0,0 @@ -package VN3::User::Lib; - -use VN3::Prelude; - -our @EXPORT = qw/show_list TopNav/; - - -# Whether we can see the user's list -sub show_list { - my $u = shift; - die "Can't determine show_list() when hide_list preference is not known" if !exists $u->{hide_list}; - auth->permUsermod || !$u->{hide_list} || $u->{id} == (auth->uid||0); -} - - -sub TopNav { - my($page, $u) = @_; - - Div class => 'nav raised-top-nav', sub { - Div mkclass('nav__item' => 1, 'nav__item--active' => $page eq 'details'), sub { A href => "/u$u->{id}", class => 'nav__link', 'Details'; }; - Div mkclass('nav__item' => 1, 'nav__item--active' => $page eq 'list'), sub { A href => "/u$u->{id}/list", class => 'nav__link', 'List'; } if show_list $u; - Div mkclass('nav__item' => 1, 'nav__item--active' => $page eq 'wish'), sub { A href => "/u$u->{id}/wish", class => 'nav__link', 'Wishlist'; } if show_list $u; - Div mkclass('nav__item' => 1, 'nav__item--active' => $page eq 'posts'), sub { A href => "/u$u->{id}/posts", class => 'nav__link', 'Posts'; }; - Div mkclass('nav__item' => 1, 'nav__item--active' => $page eq 'discussions'),sub { A href => "/t/u$u->{id}", class => 'nav__link', 'Discussions'; }; - Div mkclass('nav__item' => 1, 'nav__item--active' => $page eq 'tags'), sub { A href => "/g/links?uid=$u->{id}", class => 'nav__link', 'Tags'; }; - Div mkclass('nav__item' => 1, 'nav__item--active' => $page eq 'hist'), sub { A href => "/u$u->{id}/hist", class => 'nav__link', 'Contributions'; }; - }; -} - -1; - diff --git a/lib/VN3/User/Login.pm b/lib/VN3/User/Login.pm deleted file mode 100644 index 7660762a..00000000 --- a/lib/VN3/User/Login.pm +++ /dev/null @@ -1,50 +0,0 @@ -package VN3::User::Login; - -use VN3::Prelude; - -# TODO: Redirect to a password change form when a user logs in with an insecure password. - -TUWF::get '/u/login' => sub { - return tuwf->resRedirect('/', 'temp') if auth; - Framework title => 'Login', center => 1, sub { - Div 'data-elm-module' => 'User.Login', ''; - }; -}; - - -my $elm_Throttled = elm_api 'Throttled'; -my $elm_BadLogin = elm_api 'BadLogin'; - -json_api '/u/login', { - username => { username => 1 }, - password => { password => 1 } -}, sub { - my $data = shift; - - my $conf = tuwf->conf->{login_throttle} || [ 24*3600/10, 24*3600 ]; - my $ip = norm_ip tuwf->reqIP; - - my $tm = tuwf->dbVali( - 'SELECT', sql_totime('greatest(timeout, now())'), 'FROM login_throttle WHERE ip =', \$ip - ) || time; - - return $elm_Throttled->() if $tm-time() > $conf->[1]; - return $elm_Success->() if auth->login($data->{username}, $data->{password}); - - # Failed login, update throttle. - my $upd = { - ip => \$ip, - timeout => sql_fromtime $tm+$conf->[0] - }; - tuwf->dbExeci('INSERT INTO login_throttle', $upd, 'ON CONFLICT (ip) DO UPDATE SET', $upd); - $elm_BadLogin->() -}; - - -TUWF::get qr{/$UID_RE/logout}, sub { - return tuwf->resNotFound if !auth || auth->uid != tuwf->capture('id'); - auth->logout; - tuwf->resRedirect('/', 'temp'); -}; - -1; diff --git a/lib/VN3/User/Page.pm b/lib/VN3/User/Page.pm deleted file mode 100644 index 886ad39a..00000000 --- a/lib/VN3/User/Page.pm +++ /dev/null @@ -1,207 +0,0 @@ -package VN3::User::Page; - -use VN3::Prelude; -use VN3::User::Lib; - - -sub StatsLeft { - my $u = shift; - my $vns = show_list($u) && tuwf->dbVali('SELECT COUNT(*) FROM vnlists WHERE uid =', \$u->{id}); - my $rel = show_list($u) && tuwf->dbVali('SELECT COUNT(*) FROM rlists WHERE uid =', \$u->{id}); - my $posts = tuwf->dbVali('SELECT COUNT(*) FROM threads_posts WHERE uid =', \$u->{id}); - my $threads = tuwf->dbVali('SELECT COUNT(*) FROM threads_posts WHERE num = 1 AND uid =', \$u->{id}); - - Div class => 'card__title mb-4', 'Stats'; - Div class => 'big-stats mb-5', sub { - A href => "/u$u->{id}/list", class => 'big-stats__stat', sub { - Txt 'Votes'; - Div class => 'big-stats__value', show_list($u) ? $u->{c_votes} : '-'; - }; - A href => "/u$u->{id}/hist", class => 'big-stats__stat', sub { - Txt 'Edits'; - Div class => 'big-stats__value', $u->{c_changes}; - }; - A href => "/g/links?u=$u->{id}", class => 'big-stats__stat', sub { - Txt 'Tags'; - Div class => 'big-stats__value', $u->{c_tags}; - }; - }; - Div class => 'user-stats__text', sub { - Dl class => 'dl--horizontal', sub { - if(show_list $u) { - Dt 'List stats'; - Dd sprintf '%d release%s of %d visual novel%s', $rel, $rel == 1 ? '' : 's', $vns, $vns == 1 ? '' : 's'; - } - Dt 'Forum stats'; - Dd sprintf '%d post%s, %d new thread%s', $posts, $posts == 1 ? '' : 's', $threads, $threads == 1 ? '' : 's'; - Dt 'Registered'; - Dd date_display $u->{registered}; - }; - }; -} - - -sub Stats { - my $u = shift; - - my($count, $Graph) = show_list($u) ? VoteGraph u => $u->{id} : (); - - Div class => 'card card--white card--no-separators flex-expand mb-5', sub { - Div class => 'card__section fs-medium', sub { - Div class => 'user-stats', sub { - Div class => 'user-stats__left', sub { StatsLeft $u }; - Div class => 'user-stats__right', sub { - Div class => 'card__title mb-2', 'Vote distribution'; - $Graph->(); - } if $count; - } - } - } -} - - -sub List { - my $u = shift; - return if !show_list $u; - - # XXX: This query doesn't catch vote or list *changes*, only new entries. - # We don't store the modification date in the DB at the moment. - my $l = tuwf->dbAlli(q{ - SELECT il.vid, EXTRACT('epoch' FROM GREATEST(v.date, l.added)) AS date, vn.title, vn.original, v.vote, l.status - FROM ( - SELECT vid FROM votes WHERE uid = }, \$u->{id}, q{ - UNION SELECT vid FROM vnlists WHERE uid = }, \$u->{id}, q{ - ) AS il (vid) - LEFT JOIN votes v ON v.vid = il.vid - LEFT JOIN vnlists l ON l.vid = il.vid - JOIN vn ON vn.id = il.vid - WHERE v.uid = }, \$u->{id}, q{ - AND l.uid = }, \$u->{id}, q{ - ORDER BY GREATEST(v.date, l.added) DESC - LIMIT 10 - }); - return if !@$l; - - Div class => 'card card--white card--no-separators mb-5', sub { - Div class => 'card__header', sub { - Div class => 'card__title', 'Recent list additions'; - }; - Table class => 'table table--responsive-single-sm fs-medium', sub { - Thead sub { - Tr sub { - Th width => '15%', 'Date'; - Th width => '50%', 'Visual novel'; - Th width => '10%', 'Vote'; - Th width => '25%', 'Status'; - }; - }; - Tbody sub { - for my $i (@$l) { - Tr sub { - Td class => 'tabular-nums muted', date_display $i->{date}; - Td sub { - A href => "/v$i->{vid}", title => $i->{original}||$i->{title}, $i->{title}; - }; - Td vote_display $i->{vote}; - Td $i->{status} ? $VNLIST_STATUS{$i->{status}} : ''; - }; - } - }; - }; - Div class => 'card__section fs-medium', sub { - A href => "/u$u->{id}/list", 'View full list'; - } - }; -} - - -sub Edits { - my $u = shift; - # XXX: This is a lazy implementation, could probably share code/UI with the database entry history tables (as in VNDB 2) - - my $l = tuwf->dbAlli(q{ - SELECT ch.id, ch.itemid, ch.rev, ch.type, EXTRACT('epoch' FROM ch.added) AS added - FROM changes ch - WHERE ch.requester =}, \$u->{id}, q{ - ORDER BY ch.added DESC LIMIT 10 - }); - return if !@$l; - - # This can also be written as a UNION, haven't done any benchmarking yet. - # It doesn't matter much with only 10 entries, but it will matter if this - # query is re-used for other history browsing purposes. - enrich id => q{ - SELECT ch.id, COALESCE(d.title, v.title, p.name, r.title, c.name, sa.name) AS title - FROM changes ch - LEFT JOIN docs_hist d ON ch.type = 'd' AND d.chid = ch.id - LEFT JOIN vn_hist v ON ch.type = 'v' AND v.chid = ch.id - LEFT JOIN producers_hist p ON ch.type = 'p' AND p.chid = ch.id - LEFT JOIN releases_hist r ON ch.type = 'r' AND r.chid = ch.id - LEFT JOIN chars_hist c ON ch.type = 'c' AND c.chid = ch.id - LEFT JOIN staff_hist s ON ch.type = 's' AND s.chid = ch.id - LEFT JOIN staff_alias_hist sa ON ch.type = 's' AND sa.chid = ch.id AND s.aid = sa.aid - WHERE ch.id IN}, $l; - - Div class => 'card card--white card--no-separators mb-5', sub { - Div class => 'card__header', sub { - Div class => 'card__title', 'Recent database contributions'; - }; - Table class => 'table table--responsive-single-sm fs-medium', sub { - Thead sub { - Tr sub { - Th width => '15%', 'Date'; - Th width => '10%', 'Rev.'; - Th width => '75%', 'Entry'; - }; - }; - Tbody sub { - for my $i (@$l) { - my $id = "$i->{type}$i->{itemid}.$i->{rev}"; - Tr sub { - Td class => 'tabular-nums muted', date_display $i->{added}; - Td sub { - A href => "/$id", $id; - }; - Td sub { - A href => "/$id", $i->{title}; - }; - } - } - } - }; - Div class => 'card__section fs-medium', sub { - A href => "/u$u->{id}/hist", 'View all'; - } - }; -} - - -TUWF::get qr{/$UID_RE}, sub { - my $uid = tuwf->capture('id'); - my $u = tuwf->dbRowi(q{ - SELECT u.id, u.username, EXTRACT('epoch' FROM u.registered) AS registered, u.c_votes, u.c_changes, u.c_tags, hd.value AS hide_list - FROM users u - LEFT JOIN users_prefs hd ON hd.uid = u.id AND hd.key = 'hide_list' - WHERE u.id =}, \$uid - ); - return tuwf->resNotFound if !$u->{id}; - - Framework - title => lcfirst($u->{username}), - index => 0, - single_col => 1, - top => sub { - Div class => 'col-md', sub { - EntryEdit u => $u; - Div class => 'detail-page-title', ucfirst $u->{username}; - TopNav details => $u; - } - }, - sub { - Stats $u; - List $u; - Edits $u; - }; -}; - -1; diff --git a/lib/VN3/User/RegReset.pm b/lib/VN3/User/RegReset.pm deleted file mode 100644 index ed815547..00000000 --- a/lib/VN3/User/RegReset.pm +++ /dev/null @@ -1,137 +0,0 @@ -# User registration and password reset. These functions share some common code. -package VN3::User::RegReset; - -use VN3::Prelude; - - -TUWF::get '/u/newpass' => sub { - return tuwf->resRedirect('/', 'temp') if auth; - Framework title => 'Password reset', center => 1, sub { - Div 'data-elm-module' => 'User.PassReset', ''; - }; -}; - - -my $elm_BadEmail = elm_api 'BadEmail'; -my $elm_BadPass = elm_api 'BadPass'; -my $elm_Bot = elm_api 'Bot'; -my $elm_Taken = elm_api 'Taken'; -my $elm_DoubleEmail = elm_api 'DoubleEmail'; -my $elm_DoubleIP = elm_api 'DoubleIP'; - - -json_api '/u/newpass', { - email => { email => 1 }, -}, sub { - my $data = shift; - - my($id, $token) = auth->resetpass($data->{email}); - return $elm_BadEmail->() if !$id; - - my $name = tuwf->dbVali('SELECT username FROM users WHERE id =', \$id); - my $body = sprintf - "Hello %s," - ."\n\n" - ."Your VNDB.org login has been disabled, you can now set a new password by following the link below:" - ."\n\n" - ."%s" - ."\n\n" - ."Now don't forget your password again! :-)" - ."\n\n" - ."vndb.org", - $name, tuwf->reqBaseURI()."/u$id/setpass/$token"; - - tuwf->mail($body, - To => $data->{email}, - From => 'VNDB <noreply@vndb.org>', - Subject => "Password reset for $name", - ); - $elm_Success->(); -}; - - -my $reset_url = qr{/$UID_RE/setpass/(?<token>[a-f0-9]{40})}; - -TUWF::get $reset_url, sub { - return tuwf->resRedirect('/', 'temp') if auth; - - my $id = tuwf->capture('id'); - my $token = tuwf->capture('token'); - my $name = tuwf->dbVali('SELECT username FROM users WHERE id =', \$id); - - return tuwf->resNotFound if !$name || !auth->isvalidtoken($id, $token); - - Framework title => 'Set password', center => 1, sub { - Div 'data-elm-module' => 'User.PassSet', 'data-elm-flags' => '"'.tuwf->reqPath().'"', ''; - }; -}; - - -json_api $reset_url, { - pass => { password => 1 }, -}, sub { - my $data = shift; - my $id = tuwf->capture('id'); - my $token = tuwf->capture('token'); - - return $elm_BadPass->() if tuwf->isUnsafePass($data->{pass}); - die "Invalid reset token" if !auth->setpass($id, $token, undef, $data->{pass}); - tuwf->dbExeci('UPDATE users SET email_confirmed = true WHERE id =', \$id); - $elm_Success->() -}; - - -TUWF::get '/u/register', sub { - return tuwf->resRedirect('/', 'temp') if auth; - Framework title => 'Register', center => 1, sub { - Div 'data-elm-module' => 'User.Register', ''; - }; -}; - - -json_api '/u/register', { - username => { username => 1 }, - email => { email => 1 }, - vns => { int => 1 }, -}, sub { - my $data = shift; - - my $num = tuwf->dbVali("SELECT count FROM stats_cache WHERE section = 'vn'"); - return $elm_Bot->() if $data->{vns} < $num*0.995 || $data->{vns} > $num*1.005; - return $elm_Taken->() if tuwf->dbVali('SELECT 1 FROM users WHERE username =', \$data->{username}); - return $elm_DoubleEmail->() if tuwf->dbVali(select => sql_func user_emailexists => \$data->{email}); - - my $ip = tuwf->reqIP; - return $elm_DoubleIP->() if tuwf->dbVali( - q{SELECT 1 FROM users WHERE registered >= NOW()-'1 day'::interval AND ip <<}, - $ip =~ /:/ ? \"$ip/48" : \"$ip/30" - ); - - my $id = tuwf->dbVali('INSERT INTO users', { - username => $data->{username}, - mail => $data->{email}, - ip => $ip, - }, 'RETURNING id'); - my(undef, $token) = auth->resetpass($data->{email}); - - my $body = sprintf - "Hello %s," - ."\n\n" - ."Someone has registered an account on VNDB.org with your email address. To confirm your registration, follow the link below." - ."\n\n" - ."%s" - ."\n\n" - ."If you don't remember creating an account on VNDB.org recently, please ignore this e-mail." - ."\n\n" - ."vndb.org", - $data->{username}, tuwf->reqBaseURI()."/u$id/setpass/$token"; - - tuwf->mail($body, - To => $data->{email}, - From => 'VNDB <noreply@vndb.org>', - Subject => "Confirm registration for $data->{username}", - ); - $elm_Success->() -}; - -1; diff --git a/lib/VN3/User/Settings.pm b/lib/VN3/User/Settings.pm deleted file mode 100644 index a63de232..00000000 --- a/lib/VN3/User/Settings.pm +++ /dev/null @@ -1,98 +0,0 @@ -package VN3::User::Settings; - -use VN3::Prelude; - - -my $FORM = { - username => { username => 1 }, - mail => { email => 1 }, - perm => { uint => 1, func => sub { ($_[0] & ~auth->allPerms) == 0 } }, - ign_votes => { anybool => 1 }, - hide_list => { anybool => 1 }, - show_nsfw => { anybool => 1 }, - traits_sexual => { anybool => 1 }, - tags_all => { anybool => 1 }, - tags_cont => { anybool => 1 }, - tags_ero => { anybool => 1 }, - tags_tech => { anybool => 1 }, - spoilers => { uint => 1, range => [ 0, 2 ] }, - - password => { _when => 'in', required => 0, type => 'hash', keys => { - old => { password => 1 }, - new => { password => 1 } - } }, - - id => { _when => 'out', uint => 1 }, - authmod => { _when => 'out', anybool => 1 }, -}; - -my $FORM_OUT = form_compile out => $FORM; -my $FORM_IN = form_compile in => $FORM; - -elm_form UserEdit => $FORM_OUT, $FORM_IN; - -my $elm_BadPass = elm_api 'BadPass'; -my $elm_BadLogin = elm_api 'BadLogin'; - -TUWF::get qr{/$UID_RE/edit}, sub { - my $u = tuwf->dbRowi('SELECT id, username, perm, ign_votes FROM users WHERE id =', \tuwf->capture('id')); - - return tuwf->resNotFound if !can_edit u => $u; - - $u->{mail} = tuwf->dbVali(select => sql_func user_getmail => \$u->{id}, \auth->uid, sql_fromhex auth->token); - $u->{authmod} = auth->permUsermod; - - # Let's not disclose this (though it's not hard to find out through other means) - if(!auth->permUsermod) { - $u->{ign_votes} = 0; - $u->{perm} = auth->defaultPerms; - } - - my $prefs = { map +($_->{key}, $_->{value}), @{ tuwf->dbAlli('SELECT key, value FROM users_prefs WHERE uid =', \$u->{id}) }}; - $u->{$_} = $prefs->{$_}||'' for qw/hide_list show_nsfw traits_sexual tags_all spoilers/; - $u->{spoilers} ||= 0; - $u->{"tags_$_"} = (($prefs->{tags_cat}||'cont,tech') =~ /$_/) for qw/cont ero tech/; - - my $title = $u->{id} == auth->uid ? 'My Preferences' : "Edit $u->{username}"; - Framework title => $title, noindex => 1, narrow => 1, sub { - FullPageForm module => 'User.Settings', data => $u, schema => $FORM_OUT; - }; -}; - - -json_api qr{/$UID_RE/edit}, $FORM_IN, sub { - my $data = shift; - my $id = tuwf->capture('id'); - - return $elm_Unauth->() if !can_edit u => { id => $id }; - - if(auth->permUsermod) { - tuwf->dbExeci(update => users => set => { - username => $data->{username}, - ign_votes => $data->{ign_votes}, - email_confirmed => 1, - }, where => { id => $id }); - tuwf->dbExeci(select => sql_func user_setperm => \$id, \auth->uid, sql_fromhex(auth->token), \$data->{perm}); - } - - if($data->{password}) { - return $elm_BadPass->() if tuwf->isUnsafePass($data->{password}{new}); - - if(auth->uid == $id) { - return $elm_BadLogin->() if !auth->setpass($id, undef, $data->{password}{old}, $data->{password}{new}); - } else { - tuwf->dbExeci(select => sql_func user_admin_setpass => \$id, \auth->uid, - sql_fromhex(auth->token), sql_fromhex auth->_preparepass($data->{password}{new}) - ); - } - } - - tuwf->dbExeci(select => sql_func user_setmail => \$id, \auth->uid, sql_fromhex(auth->token), \$data->{mail}); - - auth->prefSet($_, $data->{$_}, $id) for qw/hide_list show_nsfw traits_sexual tags_all spoilers/; - auth->prefSet(tags_cat => join(',', map $data->{"tags_$_"} ? $_ : (), qw/cont ero tech/), $id); - - $elm_Success->(); -}; - -1; diff --git a/lib/VN3/User/VNList.pm b/lib/VN3/User/VNList.pm deleted file mode 100644 index 922f81d6..00000000 --- a/lib/VN3/User/VNList.pm +++ /dev/null @@ -1,325 +0,0 @@ -package VN3::User::VNList; - -use POSIX 'ceil'; -use VN3::Prelude; -use VN3::User::Lib; - - -sub mkurl { - my $opt = shift; - $opt = { %$opt, @_ }; - delete $opt->{t} if $opt->{t} == -1; - delete $opt->{g} if !$opt->{g}; - '?'.join ';', map "$_=$opt->{$_}", sort keys %$opt; -} - - -sub SideBar { - my $opt = shift; - - Div class => 'fixed-size-left-sidebar-xl', sub { - Div class => 'vertical-selector-label', 'Status'; - Div class => 'vertical-selector', sub { - for (-1, keys %VNLIST_STATUS) { - A href => mkurl($opt, t => $_, p => 1), mkclass( - 'vertical-selector__item' => 1, - 'vertical-selector__item--active' => $_ == $opt->{t} - ), $_ < 0 ? 'All' : $VNLIST_STATUS{$_}; - } - }; - }; -} - - -sub NextPrev { - my($opt, $count) = @_; - my $numpage = ceil($count/50); - - Div class => 'd-lg-flex jc-between align-items-center', sub { - Div class => 'd-flex align-items-center', ''; - Div class => 'd-block d-lg-none mb-2', ''; - Div class => 'd-flex jc-right align-items-center', sub { - A href => mkurl($opt, p => $opt->{p}-1), mkclass(btn => 1, 'btn--disabled' => $opt->{p} <= 1), '< Prev'; - Div class => 'mx-3 semi-muted', sprintf 'page %d of %d', $opt->{p}, $numpage; - A href => mkurl($opt, p => $opt->{p}+1), mkclass(btn => 1, 'btn--disabled' => $opt->{p} >= $numpage), 'Next >'; - }; - }; -} - - -sub EditDropDown { - my($u, $opt, $item) = @_; - return if $u->{id} != (auth->uid||0); - Div 'data-elm-module' => 'UVNList.Options', - 'data-elm-flags' => JSON::XS->new->encode({uid => $u->{id}, item => $item}), - ''; -} - - -sub VNTable { - my($u, $lst, $opt) = @_; - - my $SortHeader = sub { - my($id, $label) = @_; - my $isasc = $opt->{s} eq $id && $opt->{o} eq 'a'; - A mkclass( - 'table-header' => 1, - 'with-sort-icon' => 1, - 'with-sort-icon--down' => !$isasc, - 'with-sort-icon--up' => $isasc, - 'with-sort-icon--active' => $opt->{s} eq $id, - ), href => mkurl($opt, p => 1, s => $id, o => $isasc ? 'd' : 'a'), $label; - }; - - Table class => 'table table--responsive-single-sm fs-medium vn-list', sub { - Thead sub { - Tr sub { - Th width => '15%', class => 'th--nopad', sub { $SortHeader->(date => 'Date' ) }; - Th width => '40%', class => 'th--nopad', sub { $SortHeader->(title => 'Title') }; - Th width => '10%', class => 'th--nopad', sub { $SortHeader->(vote => 'Vote' ) }; - Th width => '13%', 'Status'; - Th width => '7.33%', ''; - Th width => '7.33%', ''; - Th width => '7.33%', ''; - }; - }; - Tbody sub { - for my $l (@$lst) { - Tr sub { - Td class => 'tabular-nums muted', date_display $l->{date}; - Td sub { - A href => "/v$l->{id}", title => $l->{original}||$l->{title}, $l->{title}; - }; - - if($u->{id} == (auth->uid||0)) { - Td class => 'table-edit-overlay-base', sub { - Div 'data-elm-module' => 'UVNList.Vote', - 'data-elm-flags' => JSON::XS->new->encode({uid => int $u->{id}, vid => int $l->{id}, vote => ''.vote_display $l->{vote}}), - vote_display $l->{vote}; - }; - Td class => 'table-edit-overlay-base', sub { - Div 'data-elm-module' => 'UVNList.Status', - 'data-elm-flags' => JSON::XS->new->encode({uid => int $u->{id}, vid => int $l->{id}, status => int $l->{status}||0}), - $VNLIST_STATUS{$l->{status}||0}; - }; - } else { - Td vote_display $l->{vote}; - Td $VNLIST_STATUS{$l->{status}||0}; - } - - # Release info - Td sub { - A href => 'javascript:;', class => 'vn-list__expand-releases', sub { - Span class => 'expand-arrow mr-2', ''; - Txt sprintf '%d/%d', (scalar grep $_->{status}==2, @{$l->{rel}}), scalar @{$l->{rel}}; - } if @{$l->{rel}}; - }; - - # Notes - Td sub { - # TODO: vn-list__expand-comment--empty for 'add comment' things - A href => 'javascript:;', class => 'vn-list__expand-comment', sub { - Span class => 'expand-arrow mr-2', ''; - Img class => 'svg-icon', src => tuwf->conf->{url_static}.'/v3/heavy/comment.svg'; - } if $l->{notes}; - }; - - Td sub { EditDropDown $u, $opt, $l }; - }; - - # Release info - Tr class => 'vn-list__releases-row d-none', sub { - Td colspan => '6', sub { - Div class => 'vn-list__releases', sub { - Table class => 'table table--responsive-single-sm ml-3', sub { - Tbody sub { - for my $r (@{$l->{rel}}) { - Tr sub { - Td width => '15%', class => 'tabular-nums muted pl-0', date_display $r->{date}; - Td width => '50%', sub { - A href => "/v$r->{rid}", title => $r->{original}||$r->{title}, $r->{title}; - }; - # TODO: Editabe - Td width => '20%', $RLIST_STATUS{$l->{status}}; - Td width => '15%', ''; # TODO: Edit menu - } - } - } - } - } - } - } if @{$l->{rel}}; - - # Notes - Tr class => 'vn-list__comment-row d-none', sub { - Td colspan => '6', sub { - # TODO: Editable - Div class => 'vn-list__comment ml-3', $l->{notes}; - } - } if $l->{notes}; - }; - }; - }; -} - - -sub VNGrid { - my($u, $lst, $opt) = @_; - - Div class => 'vn-grid mb-4', sub { - for my $l (@$lst) { - Div class => 'vn-grid__item', sub { - # TODO: NSFW hiding? What about missing images? - Div class => 'vn-grid__item-bg', style => sprintf("background-image: url('%s')", tuwf->imgurl(cv => $l->{image})), ''; - Div class => 'vn-grid__item-overlay', sub { - A href => 'javascript:;', class => 'vn-grid__item-link', ''; # TODO: Open modal on click - Div class => 'vn-grid__item-top', sub { - EditDropDown $u, $opt, $l; - Div class => 'vn-grid__item-rating', sub { - Img class => 'svg-icon', src => tuwf->conf->{url_static}.'/v3/heavy/comment.svg' if $l->{notes}; - Lit ' '; - Txt vote_display $l->{vote}; - } - }; - Div class => 'vn-grid__item-name', $l->{title}; - } - } - } - } -} - - -sub List { - my($u, $opt) = @_; - - my $lst = tuwf->dbAlli(q{ - SELECT v.id, v.title, v.original, vl.status, vl.notes, vo.vote, v.image, }, - sql_totime('LEAST(vl.added, vo.date)'), q{AS date, - count(*) OVER() AS full_count - FROM vn v - LEFT JOIN votes vo ON vo.vid = v.id AND vo.uid =}, \$u->{id}, q{ - LEFT JOIN vnlists vl ON vl.vid = v.id AND vl.uid =}, \$u->{id}, q{ - WHERE }, sql_and( - 'vo.vid IS NOT NULL OR vl.vid IS NOT NULL', - $opt->{t} >= 1 ? sql('vl.status =', \$opt->{t}) : $opt->{t} == 0 ? 'vl.status = 0 OR vl.status IS NULL' : () - ), - 'ORDER BY', { - title => 'v.title', - date => 'LEAST(vl.added, vo.date)', - vote => 'vo.vote', - }->{$opt->{s}}, - $opt->{o} eq 'a' ? 'ASC' : 'DESC', - 'NULLS LAST', - 'LIMIT', \50, - 'OFFSET', \(($opt->{p}-1)*50) - ); - my $count = @$lst ? $lst->[0]{full_count} : 0; - delete $_->{full_count} for @$lst; - - enrich_list rel => id => vid => sub { sql q{ - SELECT rv.vid, rl.rid, rl.status, r.title, r.original, }, sql_totime('rl.added'), q{ AS date - FROM rlists rl - JOIN releases r ON r.id = rl.rid - JOIN releases_vn rv ON rv.id = r.id - WHERE rl.uid =}, \$u->{id}, q{AND rv.vid IN}, $_[0] - }, $lst; - - Div class => 'col-md', sub { - Div class => 'card card--white card--no-separators mb-5', sub { - Div class => 'card__header', sub { - Div class => 'card__title', 'List'; - Debug $lst; - Div class => 'card__header-buttons', sub { - Div class => 'btn-group', sub { - A href => mkurl($opt, g => 0), mkclass(btn => 1, active => !$opt->{g}, 'js-show-vn-list' => 1), \&ListIcon; - A href => mkurl($opt, g => 1), mkclass(btn => 1, active => $opt->{g}, 'js-show-vn-grid' => 1), \&GridIcon; - }; - }; - }; - - VNTable $u, $lst, $opt unless $opt->{g}; - Div class => 'card__body fs-medium', sub { - VNGrid $u, $lst, $opt if $opt->{g}; - NextPrev $opt, $count; - }; - } - }; -} - - -TUWF::get qr{/$UID_RE/list}, sub { - my $uid = tuwf->capture('id'); - my $u = tuwf->dbRowi(q{ - SELECT u.id, u.username, hd.value AS hide_list - FROM users u - LEFT JOIN users_prefs hd ON hd.uid = u.id AND hd.key = 'hide_list' - WHERE u.id =}, \$uid - ); - return tuwf->resNotFound if !$u->{id} || !show_list $u; - - my $opt = tuwf->validate(get => - t => { vnlist_status => 1, required => 0, default => -1 }, # status - p => { page => 1 }, # page - o => { enum => ['d','a'], required => 0, default => 'a' }, # order (asc/desc) - s => { enum => ['title', 'date', 'vote'], required => 0, default => 'title' }, # sort column - g => { anybool => 1 }, # grid - )->data; - - Framework - title => $u->{username}, - index => 0, - top => sub { - Div class => 'col-md', sub { - Div class => 'detail-page-title', ucfirst $u->{username}; - TopNav list => $u; - } - }, - sub { - Div class => 'row', sub { - SideBar $opt; - List $u, $opt; - }; - }; -}; - - -json_api '/u/setvote', { - uid => { id => 1 }, - vid => { id => 1 }, - vote => { vnvote => 1 } -}, sub { - my $data = shift; - return $elm_Unauth->() if (auth->uid||0) != $data->{uid}; - - tuwf->dbExeci( - 'DELETE FROM votes WHERE', - { vid => $data->{vid}, uid => $data->{uid} } - ) if !$data->{vote}; - - tuwf->dbExeci( - 'INSERT INTO votes', - { vid => $data->{vid}, uid => $data->{uid}, vote => $data->{vote} }, - 'ON CONFLICT (vid, uid) DO UPDATE SET', - { vote => $data->{vote} } - ) if $data->{vote}; - - $elm_Success->() -}; - - -json_api '/u/setvnstatus', { - uid => { id => 1 }, - vid => { id => 1 }, - status => { vnlist_status => 1 } -}, sub { - my $data = shift; - return $elm_Unauth->() if (auth->uid||0) != $data->{uid}; - - tuwf->dbExeci( - 'INSERT INTO vnlists', - { vid => $data->{vid}, uid => $data->{uid}, status => $data->{status} }, - 'ON CONFLICT (vid, uid) DO UPDATE SET', - { status => $data->{status} } - ); - $elm_Success->(); -}; diff --git a/lib/VN3/VN/Edit.pm b/lib/VN3/VN/Edit.pm deleted file mode 100644 index bee48a5f..00000000 --- a/lib/VN3/VN/Edit.pm +++ /dev/null @@ -1,187 +0,0 @@ -package VN3::VN::Edit; - -use VN3::Prelude; -use VN3::VN::Lib; - - -my $FORM = { - alias => { required => 0, default => '', maxlength => 500 }, - anime => { maxlength => 50, sort_keys => 'aid', aoh =>{ - aid => { id => 1 } - } }, - desc => { required => 0, default => '', maxlength => 10240 }, - image => { required => 0, default => 0, id => 1 }, # X - img_nsfw => { anybool => 1 }, - hidden => { anybool => 1 }, - l_encubed => { required => 0, default => '', maxlength => 100 }, - l_renai => { required => 0, default => '', maxlength => 100 }, - l_wp => { required => 0, default => '', maxlength => 150 }, - length => { vn_length => 1 }, - locked => { anybool => 1 }, - original => { required => 0, default => '', maxlength => 250 }, - relations => { maxlength => 50, sort_keys => 'vid', aoh => { - vid => { id => 1 }, # X - relation => { vn_relation => 1 }, - official => { anybool => 1 }, - title => { _when => 'out' }, - } }, - screenshots => { maxlength => 10, sort_keys => 'scr', aoh => { - scr => { id => 1 }, # X - rid => { id => 1 }, # X - nsfw => { anybool => 1 }, - width => { _when => 'out', uint => 1 }, - height => { _when => 'out', uint => 1 }, - } }, - seiyuu => { sort_keys => ['aid','cid'], aoh => { - aid => { id => 1 }, # X - cid => { id => 1 }, # X - note => { required => 0, default => '', maxlength => 250 }, - id => { _when => 'out', id => 1 }, - name => { _when => 'out' }, - } }, - staff => { sort_keys => ['aid','role'], aoh => { - aid => { id => 1 }, # X - role => { staff_role => 1 }, - note => { required => 0, default => '', maxlength => 250 }, - id => { _when => 'out', id => 1 }, - name => { _when => 'out' }, - } }, - title => { maxlength => 250 }, - - id => { _when => 'out', required => 0, id => 1 }, - authmod => { _when => 'out', anybool => 1 }, - editsum => { _when => 'in out', editsum => 1 }, - chars => { _when => 'out', aoh => { - id => { id => 1 }, - name => {}, - } }, - releases => { _when => 'out', aoh => { - id => { id => 1 }, - title => {}, - original => {}, - display => {}, - resolution=> {}, - } }, -}; - -my $FORM_OUT = form_compile out => $FORM; -my $FORM_IN = form_compile in => $FORM; -my $FORM_CMP = form_compile cmp => $FORM; - -elm_form VNEdit => $FORM_OUT, $FORM_IN; - - -TUWF::get qr{/$VREV_RE/edit} => sub { - my $vn = entry v => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound; - return tuwf->resDenied if !can_edit v => $vn; - - enrich aid => q{SELECT id, aid, name FROM staff_alias WHERE aid IN} => $vn->{staff}, $vn->{seiyuu}; - enrich vid => q{SELECT id AS vid, title FROM vn WHERE id IN} => $vn->{relations}; - enrich scr => q{SELECT id AS scr, width, height FROM screenshots WHERE id IN}, $vn->{screenshots}; - $vn->{chars} = tuwf->dbAlli('SELECT id, name FROM chars c WHERE id IN(SELECT id FROM chars_vns WHERE vid =', \$vn->{id}, ') ORDER BY name'); - - $vn->{releases} = tuwf->dbAlli('SELECT id, title, original, resolution FROM releases WHERE id IN(SELECT id FROM releases_vn WHERE vid =', \$vn->{id}, ') ORDER BY id'); - enrich_list1 lang => id => id => q{SELECT id, lang FROM releases_lang WHERE id IN}, $vn->{releases}; - $_->{display} = sprintf '[%s] %s (r%d)', join(',', @{ delete $_->{lang} }), $_->{title}, $_->{id} for @{$vn->{releases}}; - - $vn->{authmod} = auth->permDbmod; - $vn->{editsum} = $vn->{chrev} == $vn->{maxrev} ? '' : "Reverted to revision v$vn->{id}.$vn->{chrev}"; - - Framework index => 0, title => "Edit $vn->{title}", - top => sub { - Div class => 'col-md', sub { - EntryEdit v => $vn; - Div class => 'detail-page-title', sub { - Txt $vn->{title}; - Debug $vn; - }; - TopNav edit => $vn; - }; - }, sub { - FullPageForm module => 'VNEdit.Main', data => $vn, schema => $FORM_OUT, sections => [ - general => 'General info', - staff => 'Staff', - cast => 'Cast', - relations => 'Relations', - screenshots => 'Screenshots', - ]; - }; -}; - - -TUWF::get '/v/add', sub { - return tuwf->resDenied if !auth->permEdit; - Framework index => 0, title => 'Add a new visual novel', narrow => 1, sub { - Div class => 'row', sub { - Div class => 'col-md col-md--1', sub { Div 'data-elm-module' => 'VNEdit.New', '' }; - }; - }; -}; - - -json_api qr{/(?:$VID_RE/edit|v/add)}, $FORM_IN, sub { - my $data = shift; - my $new = !tuwf->capture('id'); - my $vn = $new ? { id => 0 } : entry v => tuwf->capture('id') or return tuwf->resNotFound; - - return $elm_Unauth->() if !can_edit v => $vn; - - if(!auth->permDbmod) { - $data->{hidden} = $vn->{hidden}||0; - $data->{locked} = $vn->{locked}||0; - } - - # Elm doesn't actually verify this one - die "Image not found" if $data->{image} && !-e tuwf->imgpath(cv => $data->{image}); - - die "Relation with self" if grep $_->{vid} == $vn->{id}, @{$data->{relations}}; - validate_dbid 'SELECT id FROM vn WHERE id IN', map $_->{vid}, @{$data->{relations}}; - validate_dbid 'SELECT id FROM screenshots WHERE id IN', map $_->{scr}, @{$data->{screenshots}}; - validate_dbid sql('SELECT DISTINCT id FROM releases_vn WHERE vid =', \$vn->{id}, ' AND id IN'), map $_->{rid}, @{$data->{screenshots}}; - validate_dbid 'SELECT aid FROM staff_alias WHERE aid IN', map $_->{aid}, @{$data->{seiyuu}}, @{$data->{staff}}; - validate_dbid sql('SELECT DISTINCT id FROM chars_vns WHERE vid =', \$vn->{id}, ' AND id IN'), map $_->{cid}, @{$data->{seiyuu}}; - - $data->{desc} = bb_subst_links $data->{desc}; - return $elm_Unchanged->() if !$new && !form_changed $FORM_CMP, $data, $vn; - - my($id,undef,$rev) = update_entry v => $vn->{id}, $data; - - update_reverse($id, $rev, $vn, $data); - - $elm_Changed->($id, $rev); -}; - - -sub update_reverse { - my($id, $rev, $old, $new) = @_; - - my %old = map +($_->{vid}, $_), $old->{relations} ? @{$old->{relations}} : (); - my %new = map +($_->{vid}, $_), @{$new->{relations}}; - - # Updates to be performed, vid => { vid => x, relation => y, official => z } or undef if the relation should be removed. - my %upd; - - for my $i (keys %old, keys %new) { - if($old{$i} && !$new{$i}) { - $upd{$i} = undef; - } elsif(!$old{$i} || $old{$i}{relation} ne $new{$i}{relation} || !$old{$i}{official} != !$new{$i}{official}) { - $upd{$i} = { - vid => $id, - relation => vn_relation_reverse($new{$i}{relation}), - official => $new{$i}{official} - }; - } - } - - for my $i (keys %upd) { - my $v = entry v => $i; - $v->{relations} = [ - $upd{$i} ? $upd{$i} : (), - grep $_->{vid} != $id, @{$v->{relations}} - ]; - $v->{editsum} = "Reverse relation update caused by revision v$id.$rev"; - update_entry v => $i, $v, 1; - } -} - -1; diff --git a/lib/VN3/VN/JS.pm b/lib/VN3/VN/JS.pm deleted file mode 100644 index ec98b768..00000000 --- a/lib/VN3/VN/JS.pm +++ /dev/null @@ -1,46 +0,0 @@ -package VN3::VN::JS; - -use VN3::Prelude; - - -my $elm_VNResult = elm_api VNResult => { aoh => { - id => { id => 1 }, - title => {}, - original => {}, - hidden => { anybool => 1 }, -}}; - - -json_api '/js/vn.json', { - search => { type => 'array', scalar => 1, minlength => 1, values => { maxlength => 500 } }, - hidden => { anybool => 1 } -}, sub { - my $data = shift; - - my $r = tuwf->dbAlli( - 'SELECT v.id, v.title, v.original, v.hidden', - 'FROM (', (sql_join 'UNION ALL', map { - my $qs = s/[%_]//gr; - my @q = normalize_query $_; - +( - # ID search - /^$VID_RE$/ ? (sql 'SELECT 1, id FROM vn WHERE id =', \"$1") : (), - # prefix match - sql('SELECT 2, id FROM vn WHERE title ILIKE', \"$qs%"), - # substring match - @q ? (sql 'SELECT 3, id FROM vn WHERE', sql_and map sql('c_search ILIKE', \"%$_%"), @q) : () - ) - } @{$data->{search}}), - ') AS vt (ord, id)', - 'JOIN vn v ON v.id = vt.id', - $data->{hidden} ? () : ('WHERE NOT v.hidden'), - 'GROUP BY v.id, v.title, v.original', - 'ORDER BY MIN(vt.ord), v.title', - 'LIMIT 20' - ); - - $elm_VNResult->($r); -}; - -1; - diff --git a/lib/VN3/VN/Lib.pm b/lib/VN3/VN/Lib.pm deleted file mode 100644 index 9571cef8..00000000 --- a/lib/VN3/VN/Lib.pm +++ /dev/null @@ -1,20 +0,0 @@ -package VN3::VN::Lib; - -use VN3::Prelude; - -our @EXPORT = qw/TopNav/; - - -sub TopNav { - my($page, $v) = @_; - - my $rg = exists $v->{rgraph} ? $v->{rgraph} : tuwf->dbVali('SELECT rgraph FROM vn WHERE id=', \$v->{id}); - - Div class => 'nav raised-top-nav', sub { - Div mkclass('nav__item' => 1, 'nav__item--active' => $page eq 'details'), sub { A href => "/v$v->{id}", class => 'nav__link', 'Details'; }; - Div mkclass('nav__item' => 1, 'nav__item--active' => $page eq 'discussions'),sub { A href => "/t/v$v->{id}", class => 'nav__link', 'Discussions'; }; # TODO: count - Div mkclass('nav__item' => 1, 'nav__item--active' => $page eq 'relations'), sub { A href => "/v$v->{id}/rg", class => 'nav__link', 'Relations'; } if $rg; - }; -} - -1; diff --git a/lib/VN3/VN/Page.pm b/lib/VN3/VN/Page.pm deleted file mode 100644 index a09bbeb9..00000000 --- a/lib/VN3/VN/Page.pm +++ /dev/null @@ -1,631 +0,0 @@ -package VN3::VN::Page; - -use VN3::Prelude; -use VN3::VN::Lib; - - -TUWF::get '/v/rand', sub { - # TODO: Apply stored filters? - my $vid = tuwf->dbVal('SELECT id FROM vn WHERE NOT hidden ORDER BY RANDOM() LIMIT 1'); - tuwf->resRedirect("/v$vid", 'temp'); -}; - - -sub CVImage { - my($vn, $class, $class_sfw, $class_nsfw) = @_; - return if !$vn->{image}; - - my $img = tuwf->imgurl(cv => $vn->{image}); - my $nsfw = tuwf->conf->{url_static}.'/v3/nsfw.svg'; - Img class => $class.' '.($vn->{img_nsfw} ? $class_nsfw : $class_sfw), - !$vn->{img_nsfw} ? (src => $img) - : auth->pref('show_nsfw') ? (src => $img, 'data-toggle-img' => $nsfw) - : (src => $nsfw, 'data-toggle-img' => $img); -} - - -sub Top { - my $vn = shift; - Div class => 'fixed-size-left-sidebar-md', ''; - Div class => 'col-md', sub { - Div class => 'vn-header', sub { - EntryEdit v => $vn; - CVImage $vn, 'page-header-img-mobile img img--rounded d-md-none', '', 'nsfw-outline'; - Div class => 'vn-header__title', $vn->{title}; - Div class => 'vn-header__original-title', $vn->{original} if $vn->{original}; - Div class => 'vn-header__details', sub { - Txt $vn->{c_rating} ? sprintf '%.1f ', $vn->{c_rating}/10 : '-'; - Div class => 'vn-header__sep', ''; - Txt vn_length_time $vn->{length}; - Div class => 'vn-header__sep', ''; - Txt join ', ', map $LANGUAGE{$_}, @{$vn->{c_languages}}; - Debug $vn; - }; - }; - TopNav details => $vn; - }; -} - - -sub SidebarProd { - my $vn = shift; - - my $prod = tuwf->dbAlli(q{ - SELECT p.id, p.name, p.original, bool_or(rp.developer) AS dev, bool_or(rp.publisher) AS pub - FROM releases r - JOIN releases_producers rp ON rp.id = r.id - JOIN releases_vn rv ON rv.id = r.id - JOIN producers p ON rp.pid = p.id - WHERE rv.vid =}, \$vn->{id}, q{ - AND NOT r.hidden - GROUP BY p.id, p.name, p.original - ORDER BY p.name - }); - - my $Fmt = sub { - my($single, $multi, @lst) = @_; - - Dt @lst == 1 ? $single : $multi; - Dd sub { - Join ', ', sub { - A href => "/p$_[0]{id}", title => $_[0]{original}||$_[0]{name}, $_[0]{name} - }, @lst; - }; - }; - - $Fmt->('Developer', 'Developers', grep $_->{dev}, @$prod); - $Fmt->('Publisher', 'Publishers', grep $_->{pub}, @$prod); -} - - -sub SidebarRel { - my $vn = shift; - return if !@{$vn->{relations}}; - - Dt 'Relations'; - Dd sub { - Dl sub { - for my $type (keys %VN_RELATION) { - my @rel = grep $_->{relation} eq $type, @{$vn->{relations}}; - next if !@rel; - Dt vn_relation_display $type; - Dd class => 'single-line-md', sub { - Span 'unofficial ' if !$_->{official}; - A href => "/v$_->{vid}", title => $_->{original}||$_->{title}, $_->{title}; - } for @rel; - } - } - } -} - - -sub Sidebar { - my $vn = shift; - - CVImage $vn, 'img img--fit img--rounded d-none d-md-block vn-img-desktop', 'elevation-1', 'elevation-1-nsfw' if $vn->{image}; - Div class => 'vn-image-placeholder img--rounded elevation-1 d-none d-md-block vn-img-desktop', sub { - Div class => 'vn-image-placeholder__icon', sub { - Img class => 'svg-icon', src => tuwf->conf->{url_static}.'/v3/camera-alt.svg'; - } - } if !$vn->{image}; - - Div class => 'add-to-list elevated-button elevation-1', sub { - Img class => 'svg-icon', src => tuwf->conf->{url_static}.'/v3/plus.svg'; - Txt 'Add to my list'; - }; - - Dl class => 'vn-page__dl', sub { - if($vn->{original}) { - Dt 'Original Title'; - Dd $vn->{original}; - } - - Dt 'Main Title'; - Dd $vn->{title}; - - if($vn->{alias}) { - Dt 'Aliases'; - Dd $vn->{alias} =~ s/\n/, /gr; - } - - if($vn->{length}) { - Dt 'Length'; - Dd vn_length_display $vn->{length}; - } - - SidebarProd $vn; - SidebarRel $vn; - - # TODO: Affiliate links - # TODO: Anime - }; -} - - -sub Tags { - my $vn = shift; - - my $tag_rating = 'avg(CASE WHEN tv.ignore THEN NULL ELSE tv.vote END)'; - my $tags = tuwf->dbAlli(qq{ - SELECT tv.tag, t.name, t.cat, count(*) as cnt, $tag_rating as rating, - COALESCE(avg(CASE WHEN tv.ignore THEN NULL ELSE tv.spoiler END), t.defaultspoil) as spoiler - FROM tags_vn tv - JOIN tags t ON tv.tag = t.id - WHERE tv.vid =}, \$vn->{id}, qq{ - AND t.state = 1+1 - GROUP BY tv.tag, t.name, t.cat, t.defaultspoil - HAVING $tag_rating > 0 - ORDER BY $tag_rating DESC - }); - - my $spoil = auth->pref('spoilers') || 0; - my $cat = auth->pref('tags_cat') || 'cont,tech'; - my %cat = map +($_, !!($cat =~ /$_/)), qw/cont ero tech/; - - Div mkclass( - 'tag-summary__tags' => 1, - 'tag-summary--collapsed' => 1, - 'tag-summary--hide-spoil-1' => $spoil < 1, - 'tag-summary--hide-spoil-2' => $spoil < 2, - map +("tag-summary--hide-$_", !$cat{$_}), keys %cat - ), sub { - for my $tag (@$tags) { - Div class => sprintf( - 'tag-summary__tag tag-summary__tag--%s tag-summary__tag--spoil-%d', - $tag->{cat}, $tag->{spoiler} > 1.3 ? 2 : $tag->{spoiler} > 0.4 ? 1 : 0 - ), sub { - A href => "/g$tag->{tag}", class => 'link--subtle', $tag->{name}; - Div class => 'tag-summary__tag-meter', style => sprintf('width: %dpx', $tag->{rating}*10), ''; - }; - } - }; - - Div class => 'tag-summary__options', sub { - Div class => 'tag-summary__options-left', sub { - A href => 'javascript:;', class => 'link--subtle d-none tag-summary__show-all', sub { - Span class => 'caret caret--pre', ''; - Txt ' Show all tags'; - }; - Debug $tags; - }; - Div class => 'tag-summary__options-right', sub { - Div class => 'tag-summary__option dropdown', sub { - A href => 'javascript:;', class => 'link--subtle dropdown__toggle', sub { - Span class => 'tag-summary_option--spoil', spoil_display $spoil; - Lit ' '; - Span class => 'caret', ''; - }; - Div class => 'dropdown-menu', sub { - A class => 'dropdown-menu__item tag-summary_option--spoil-0', href => 'javascript:;', spoil_display 0; - A class => 'dropdown-menu__item tag-summary_option--spoil-1', href => 'javascript:;', spoil_display 1; - A class => 'dropdown-menu__item tag-summary_option--spoil-2', href => 'javascript:;', spoil_display 2; - }; - }; - Div class => 'tag-summary__option', sub { Switch 'Content', $cat{cont}, 'tag-summary__option--cont' => 1; }; - Div class => 'tag-summary__option', sub { Switch 'Sexual', $cat{ero}, 'tag-summary__option--ero' => 1; }; - Div class => 'tag-summary__option', sub { Switch 'Technical', $cat{tech}, 'tag-summary__option--tech' => 1; }; - }; - }; -} - - -sub Releases { - my $vn = shift; - - my %lang; - my @lang = grep !$lang{$_}++, map @{$_->{lang}}, @{$vn->{releases}}; - - for my $lang (@lang) { - Div class => 'relsm__language', sub { - Lang $lang; - Txt " $LANGUAGE{$lang}"; - }; - Div class => 'relsm__table', sub { - Div class => 'relsm__rel', sub { - my $rel = $_; - - Div class => 'relsm__rel-col relsm__rel-date tabular-nums', sub { ReleaseDate $rel->{released}; }; - A class => 'relsm__rel-col relsm__rel-name', href => "/r$rel->{id}", title => $rel->{original}||$rel->{title}, $rel->{title}; - Div class => 'relsm__rel-col relsm__rel-platforms', sub { Platform $_ for @{$rel->{platforms}} }; - Div class => 'relsm__rel-col relsm__rel-mylist', sub { - # TODO: Make this do something - Img class => 'svg-icon', src => tuwf->conf->{url_static}.'/v3/plus-circle.svg'; - }; - if($rel->{website}) { - Div class => 'relsm__rel-col relsm__rel-link', sub { - A href => $rel->{website}, 'Link'; - }; - } else { - Div class => 'relsm__rel-col relsm__rel-link relsm__rel-link--none', 'Link'; - } - - # TODO: Age rating - # TODO: Release type - # TODO: Release icons - } for grep grep($_ eq $lang, @{$_->{lang}}), @{$vn->{releases}}; - } - } -} - - -sub Staff { - my $vn = shift; - return if !@{$vn->{staff}}; - - my $Role = sub { - my $role = shift; - my @staff = grep $_->{role} eq $role, @{$vn->{staff}}; - return if !@staff; - - Div class => 'staff-credits__section', sub { - Div class => 'staff-credits__section-title', $CREDIT_TYPE{$role}; - Div class => 'staff-credits__item', sub { - A href => "/s$_->{id}", title => $_->{original}||$_->{name}, $_->{name}; - Span class => 'staff-credits__note', " $_->{note}" if $_->{note}; - } for (@staff); - }; - }; - - Div class => 'section', id => 'staff', sub { - H2 class => 'section__title', 'Staff'; - Div class => 'staff-credits js-columnize', 'data-columns' => 3, sub { - $Role->($_) for keys %CREDIT_TYPE; - }; - }; -} - - -sub Gallery { - my $vn = shift; - - return if !@{$vn->{screenshots}}; - my $show = auth->pref('show_nsfw'); - - Div mkclass(section => 1, gallery => 1, 'gallery--show-r18' => $show), id => 'gallery', sub { - H2 class => 'section__title', sub { - Switch '18+', $show, 'gallery-r18-toggle' => 1 if grep $_->{nsfw}, @{$vn->{screenshots}}; - Txt 'Gallery'; - }; - - # TODO: Thumbnails are being upscaled, we should probably recreate all thumbnails at higher resolution - - Div class => 'gallery__section', sub { - for my $s (@{$vn->{screenshots}}) { - my $r = (grep $_->{id} == $s->{rid}, @{$vn->{releases}})[0]; - my $meta = { - width => 1*$s->{width}, - height => 1*$s->{height}, - rel => { - id => 1*$s->{rid}, - title => $r->{title}, - lang => $r->{lang}, - plat => $r->{platforms}, - } - }; - - A mkclass('gallery__image-link' => 1, 'gallery__image--r18' => $s->{nsfw}), - 'data-lightbox-nfo' => JSON::XS->new->encode($meta), - href => tuwf->imgurl(sf => $s->{scr}), - sub { - Img mkclass(gallery__image => 1, 'nsfw-outline' => $s->{nsfw}), src => tuwf->imgurl(st => $s->{scr}); - } - } - } - }; -} - - -sub CharacterList { - my($vn, $roles, $first_char) = @_; - - # TODO: Implement spoiler & sexual stuff settings - # TODO: Make long character lists collapsable - - Div class => 'character-browser__top-item dropdown', sub { - A href => 'javascript:;', class => 'link--subtle dropdown__toggle', sub { - Txt spoil_display 0; - Lit ' '; - Span class => 'caret', ''; - }; - Div class => 'dropdown-menu', sub { - A class => 'dropdown-menu__item', href => 'javascript:;', spoil_display 0; - A class => 'dropdown-menu__item', href => 'javascript:;', spoil_display 1; - A class => 'dropdown-menu__item', href => 'javascript:;', spoil_display 2; - }; - }; - Div class => 'character-browser__top-item d-none d-md-block', sub { Switch 'Sexual traits', 0 }; - Div class => 'character-browser__top-item', sub { - A href => "/v$vn->{id}/chars", 'View all on one page'; - }; - - Div class => 'character-browser__list', sub { - Div class => 'character-browser__list-title', char_role_display $_, scalar @{$roles->{$_}}; - A mkclass('character-browser__char' => 1, 'character-browser__char--active' => $_->{id} == $first_char), - href => "/c$_->{id}", title => $_->{original}||$_->{name}, 'data-character' => $_->{id}, $_->{name} - for @{$roles->{$_}}; - } for grep @{$roles->{$_}}, keys %CHAR_ROLE; -} - - -sub CharacterInfo { - my $char = shift; - - Div class => 'row', sub { - Div class => 'col-md', sub { - # TODO: Gender & blood type - Div class => 'character__name', $char->{name}; - Div class => 'character__subtitle', $char->{original} if $char->{original}; - Div class => 'character__description serif', sub { - P sub { Lit bb2html $char->{desc}, 0, 1 }; - }; - }; - Div class => 'col-md character__image', sub { - Img class => 'img img--fit img--rounded', - src => tuwf->imgurl(ch => $char->{image}) - } if $char->{image}; - }; - - my(%groups, @groups); - for(@{$char->{traits}}) { - push @groups, $_->{gid} if !$groups{$_->{gid}}; - push @{$groups{$_->{gid}}}, $_; - } - - # Create a list of key/value things, so that we can neatly split them in - # two. The split occurs on the number of sections, so long sections can - # still cause some imbalance. - # TODO: Date of birth? - my @traits = ( - $char->{alias} ? sub { - Dt 'Aliases'; - Dd $char->{alias} =~ s/\n/, /gr; - } : (), - - $char->{weight} || $char->{height} || $char->{s_bust} || $char->{s_waist} || $char->{s_hip} ? sub { - Dt 'Measurements'; - Dd join ', ', - $char->{height} ? "Height: $char->{height}cm" : (), - $char->{weight} ? "Weight: $char->{weight}kg" : (), - $char->{s_bust} || $char->{s_waist} || $char->{s_hip} ? - sprintf 'Bust-Waist-Hips: %s-%s-%scm', $char->{s_bust}||'??', $char->{s_waist}||'??', $char->{s_hip}||'??' : (); - } : (), - - # TODO: Do something with spoiler settings. - (map { my $g = $_; sub { - Dt sub { A href => "/i$g", $groups{$g}[0]{group} }; - Dd sub { - Join ', ', sub { - A href => "/i$_[0]{tid}", $_[0]{name}; - }, @{$groups{$g}}; - }; - } } @groups), - - @{$char->{seiyuu}} ? sub { - Dt 'Voiced by'; - Dd sub { - my $prev = ''; - for my $s (sort { $a->{name} cmp $b->{name} } @{$char->{seiyuu}}) { - next if $s->{name} eq $prev; - A href => "/s$s->{id}", title => $s->{original}||$s->{name}, $s->{name}; - Txt ' ('.$s->{note}.')' if $s->{note}; - } - }; - } : (), - ); - - Div class => 'character__traits row mt-4', sub { - Dl class => 'col-md dl--horizontal', sub { $_->() for @traits[0..$#traits/2]; }; - Dl class => 'col-md dl--horizontal', sub { $_->() for @traits[$#traits/2+1..$#traits]; }; - } if @traits; -} - - -sub Characters { - my $vn = shift; - - # XXX: Fetching and rendering all character details on the VN page is a bit - # inefficient and bloats the HTML. We should probably load data from other - # characters on demand. - - my $chars = tuwf->dbAlli(q{ - SELECT id, name, original, alias, image, "desc", gender, s_bust, s_waist, s_hip, - b_month, b_day, height, weight, bloodt - FROM chars - WHERE NOT hidden - AND id IN(SELECT id FROM chars_vns WHERE vid =}, \$vn->{id}, q{) - ORDER BY name - }); - return if !@$chars; - - enrich_list releases => id => id => - sql('SELECT id, rid, spoil, role FROM chars_vns WHERE vid =', \$vn->{id}, ' AND id IN'), - $chars; - - # XXX: Just fetching this list takes ~10ms for a large VN (v92). I worry - # about formatting and displaying it on every page view. (This query can - # probably be sped up by grabbing/caching the group tag names separately, - # there are only 12 groups in the DB anyway). - enrich_list traits => id => id => sub {sql q{ - SELECT ct.id, ct.tid, ct.spoil, t.name, t.sexual, g.id AS gid, g.name AS group, g.order - FROM chars_traits ct - JOIN traits t ON t.id = ct.tid - JOIN traits g ON g.id = t.group - WHERE ct.id IN}, $_[0], q{ - ORDER BY g.order, t.name - }}, $chars; - - enrich_list seiyuu => id => cid => sub{sql q{ - SELECT va.id, vs.aid, vs.cid, vs.note, va.name, va.original - FROM vn_seiyuu_hist vs JOIN staff_alias va ON va.aid = vs.aid - WHERE vs.chid =}, \$vn->{chid} - }, $chars; - - my %done; - my %roles = map { - my $r = $_; - ($r, [ grep grep($_->{role} eq $r, @{$_->{releases}}) && !$done{$_->{id}}++, @$chars ]); - } keys %CHAR_ROLE; - - my($first_char) = map @{$roles{$_}} ? $roles{$_}[0]{id} : (), keys %CHAR_ROLE; - - Div class => 'section', id => 'characters', sub { - H2 class => 'section__title', sub { Txt 'Characters'; Debug \%roles }; - Div class => 'character-browser', sub { - Div class => 'row', sub { - Div class => 'fixed-size-left-sidebar-md', sub { - Div class => 'character-browser__top-items', sub { CharacterList $vn, \%roles, $first_char; } - }; - Div class => 'col-md col-md--3 d-none d-md-block', sub { - Div mkclass(character => 1, 'd-none' => $_->{id} != $first_char), 'data-character' => $_->{id}, - sub { CharacterInfo $_ } - for @$chars; - }; - }; - }; - }; -} - - -sub Stats { - my $vn = shift; - - my($has_data, $Dist) = VoteGraph v => $vn->{id}; - return if !$has_data; - - my $recent_votes = tuwf->dbAlli(q{ - SELECT v.vid, v.vote,}, sql_totime('v.date'), q{AS date, u.id, u.username - FROM votes v JOIN users u ON u.id = v.uid - WHERE NOT EXISTS(SELECT 1 FROM users_prefs WHERE uid = u.id AND key = 'hide_list') - AND NOT u.ign_votes - AND v.vid =}, \$vn->{id}, q{ - ORDER BY v.date DESC LIMIT 10 - }); - my $Recent = sub { - H4 'Recent votes'; - Div class => 'recent-votes', sub { - Table class => 'recent-votes__table tabular-numbs', sub { - Tbody sub { - Tr sub { - Td sub { A href => "/u$_->{id}", $_->{username}; }; - Td vote_display $_->{vote}; - Td date_display $_->{date}; - } for @$recent_votes; - }; - }; - Div class => 'final-text', sub { - A href => "/v$vn->{id}/votes", 'All votes'; - }; - }; - }; - - - my $popularity_rank = tuwf->dbVali( - 'SELECT COUNT(*)+1 FROM vn WHERE NOT hidden AND c_popularity >', - \($vn->{c_popularity}||0) - ); - my $rating_rank = tuwf->dbVali( - 'SELECT COUNT(*)+1 FROM vn WHERE NOT hidden AND c_rating >', - \($vn->{c_rating}||0) - ); - - my $Popularity = sub { - H4 'Ranking'; - Dl class => 'stats__ranking', sub { - Dt 'Popularity'; - Dd sprintf 'ranked #%d with a score of %.2f', $popularity_rank, 100*($vn->{c_popularity}||0); - Dt 'Bayesian rating'; - Dd sprintf 'ranked #%d with a rating of %.2f', $rating_rank, $vn->{c_rating}/10; - }; - Div class => 'final-text', sub { - A href => '/v/all', 'See best rated games'; - }; - }; - - - Div class => 'section stats', id => 'stats', sub { - H2 class => 'section__title', 'Stats'; - Div class => 'row semi-muted', sub { - Div class => 'stats__col col-md col-md-1', sub { - H4 'Vote distribution'; - $Dist->(); - }; - Div class => 'stats__col col-md col-md-1', $Recent if @$recent_votes; - Div class => 'stats__col col-md col-md-1', $Popularity; - }; - }; -} - - -sub Contents { - my $vn = shift; - - Div class => 'vn-page', sub { - Div class => 'row', sub { - Div class => 'col-md', sub { - Div class => 'row', sub { - Div class => 'fixed-size-left-sidebar-md vn-page__top-details', sub { Sidebar $vn }; - Div class => 'fixed-size-left-sidebar-md', ''; - Div class => 'col-md', sub { - Div class => 'description serif', id => 'about', sub { - P sub { Lit bb2html $vn->{desc}||'No description.' }; - }; - Div class => 'section', id => 'tags', sub { - Div class => 'tag-summary', sub { Tags $vn }; - }; - Div class => 'section', id => 'releases', sub { - H2 class => 'section__title', 'Releases'; - Div class => 'relsm', sub { Releases $vn }; - }; - Staff $vn; - Gallery $vn; - }; - }; - }; - }; - Div class => 'row', sub { - Div class => 'col-xxl', sub { - Characters $vn; - Stats $vn; - }; - }; - }; -} - - -TUWF::get qr{/$VREV_RE}, sub { - my $vn = entry v => tuwf->capture('id'), tuwf->capture('rev') or return tuwf->resNotFound; - return tuwf->resNotFound if !$vn->{id} || $vn->{hidden}; - - enrich id => q{SELECT id, rgraph, c_languages::text[], c_popularity, c_rating, c_votecount FROM vn WHERE id IN}, $vn; - enrich scr => q{SELECT id AS scr, width, height FROM screenshots WHERE id IN}, $vn->{screenshots}; - enrich vid => q{SELECT id AS vid, title, original FROM vn WHERE id IN}, $vn->{relations}; - enrich aid => q{SELECT aid, id, name, original FROM staff_alias WHERE aid IN}, $vn->{staff}; - - enrich_list releases => id => vid => sub {sql q{ - SELECT rv.vid, r.id, r.title, r.original, r.type, r.website, r.released, r.notes, - r.minage, r.patch, r.freeware, r.doujin, r.resolution, r.voiced, r.ani_story, r.ani_ero - FROM releases r - JOIN releases_vn rv ON r.id = rv.id - WHERE NOT r.hidden AND rv.vid IN}, $_[0], q{ - ORDER BY r.released - }}, $vn; - - enrich_list1 platforms => id => id => 'SELECT id, platform FROM releases_platforms WHERE id IN', $vn->{releases}; - enrich_list1 lang => id => id => 'SELECT id, lang FROM releases_lang WHERE id IN', $vn->{releases}; - enrich_list media => id => id => 'SELECT id, medium, qty FROM releases_media WHERE id IN', $vn->{releases}; - - Framework - og => { - description => bb2text($vn->{desc}), - $vn->{image} && !$vn->{img_nsfw} ? ( - image => tuwf->imgurl(cv => $vn->{image}) - ) : (($_) = grep !$_->{nsfw}, @{$vn->{screenshots}}) ? ( - image => tuwf->imgurl(st => $_->{scr}) - ) : () - }, - title => $vn->{title}, - top => sub { Top $vn }, - sub { Contents $vn }; -}; - -1; diff --git a/lib/VN3/Validation.pm b/lib/VN3/Validation.pm deleted file mode 100644 index 73bf7d62..00000000 --- a/lib/VN3/Validation.pm +++ /dev/null @@ -1,168 +0,0 @@ -# This module provides additional validations for tuwf->validate(), and exports -# a few convenient form handling/validation functions. -package VN3::Validation; - -use strict; -use warnings; -use TUWF; -use VNDBUtil; -use VNDB::Types; -use VNWeb::Auth; -use VN3::DB; -use VN3::Types; -use JSON::XS; -use Exporter 'import'; -use Time::Local 'timegm'; -use Carp 'croak'; -our @EXPORT = ('form_compile', 'form_changed', 'validate_dbid', 'can_edit'); - - -TUWF::set custom_validations => { - id => { uint => 1, max => 1<<40 }, - page => { uint => 1, min => 1, max => 1000, required => 0, default => 1 }, - username => { regex => qr/^[a-z0-9-]{2,15}$/ }, - password => { length => [ 4, 500 ] }, - editsum => { required => 1, length => [ 2, 5000 ] }, - vn_length => { required => 0, default => 0, uint => 1, enum => \%VN_LENGTH }, - vn_relation => { enum => \%VN_RELATION }, - producer_relation => { enum => \%PRODUCER_RELATION }, - staff_role => { enum => \%CREDIT_TYPE }, - char_role => { enum => \%CHAR_ROLE }, - language => { enum => \%LANGUAGE }, - platform => { enum => \%PLATFORM }, - medium => { enum => \%MEDIUM }, - resolution => { enum => \%RESOLUTION }, - gender => { enum => \%GENDER }, - blood_type => { enum => \%BLOOD_TYPE }, - gtin => { uint => 1, func => sub { $_[0] eq 0 || gtintype($_[0]) } }, - minage => { uint => 1, enum => \%AGE_RATING }, - animated => { uint => 1, enum => \%ANIMATED }, - voiced => { uint => 1, enum => \%VOICED }, - rdate => { uint => 1, func => \&_validate_rdate }, - spoiler => { uint => 1, range => [ 0, 2 ] }, - vnlist_status=>{ enum => \%VNLIST_STATUS }, - # Accepts a user-entered vote string (or '-' or empty) and converts that into a DB vote number (or undef) - vnvote => { regex => qr/^(?:|-|[1-9]|10|[1-9]\.[0-9]|10\.0)$/, required => 0, func => sub { $_[0] = $_[0] eq '-' ? undef : 10*$_[0]; 1 } }, - # Sort an array by the listed hash keys, using string comparison on each key - sort_keys => sub { - my @keys = ref $_[0] eq 'ARRAY' ? @{$_[0]} : $_[0]; - +{ type => 'array', sort => sub { - for(@keys) { - my $c = defined($_[0]{$_}) cmp defined($_[1]{$_}) || (defined($_[0]{$_}) && $_[0]{$_} cmp $_[1]{$_}); - return $c if $c; - } - 0 - } } - }, - # Sorted and unique array-of-hashes (default order is sort_keys on the sorted keys...) - aoh => sub { +{ type => 'array', unique => 1, sort_keys => [sort keys %{$_[0]}], values => { type => 'hash', keys => $_[0] } } }, -}; - - -sub _validate_rdate { - return 0 if $_[0] ne 0 && $_[0] !~ /^([0-9]{4})([0-9]{2})([0-9]{2})$/; - my($y, $m, $d) = $_[0] eq 0 ? (0,0,0) : ($1, $2, $3); - - # Re-normalize - ($m, $d) = (0, 0) if $y == 0; - $m = 99 if $y == 9999; - $d = 99 if $m == 99; - $_[0] = $y*10000 + $m*100 + $d; - - return 0 if $y && $y != 9999 && ($y < 1980 || $y > 2100); - return 0 if $y && $m != 99 && (!$m || $m > 12); - return 0 if $y && $d != 99 && !eval { timegm(0, 0, 0, $d, $m-1, $y) }; - return 1; -} - - -# 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; -} - - -# Validate identifiers against an SQL query. The query must end with a 'id IN' -# clause, where the @ids array is appended. The query must return exactly 1 -# column, the id of each entry. This function throws an error if an id is -# missing from the query. For example, to test for non-hidden VNs: -# -# validate_dbid 'SELECT id FROM vn WHERE NOT hidden AND id IN', 2,3,5,7,...; -# -# If any of those ids is hidden or not in the database, an error is thrown. -sub validate_dbid { - my($sql, @ids) = @_; - return if !@ids; - $sql = ref $sql eq 'CODE' ? sql $sql->(\@ids) : sql $sql, \@ids; - my %dbids = map +((values %$_)[0],1), @{ tuwf->dbAlli($sql) }; - my @missing = grep !$dbids{$_}, @ids; - croak "Invalid database IDs: ".join(',', @missing) if @missing; -} - - -# Returns whether the current user can edit the given database entry. -sub can_edit { - my($type, $entry) = @_; - - return auth->permUsermod || $entry->{id} == (auth->uid||0) if $type eq 'u'; - return auth->permDbmod if $type eq 'd'; - - 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}); - - auth->permDbmod || (auth->permEdit && !($entry->{entry_hidden} || $entry->{entry_locked})); -} - -1; |