diff options
Diffstat (limited to 'lib/VNWeb/DB.pm')
-rw-r--r-- | lib/VNWeb/DB.pm | 180 |
1 files changed, 180 insertions, 0 deletions
diff --git a/lib/VNWeb/DB.pm b/lib/VNWeb/DB.pm new file mode 100644 index 00000000..58a972a8 --- /dev/null +++ b/lib/VNWeb/DB.pm @@ -0,0 +1,180 @@ +package VNWeb::DB; + +use v5.24; +use warnings; +use TUWF; +use SQL::Interp ':all'; +use Carp 'carp'; +use Exporter 'import'; + +our @EXPORT = qw/ + sql + sql_join sql_comma sql_and sql_array sql_func sql_fromhex sql_tohex sql_fromtime sql_totime + enrich enrich_merge enrich_flatten +/; + + + +# Test for potential SQL injection and warn about it. This will cause some +# false positives. +# The heuristic is pretty simple: Just check if there's an integer in the SQL +# statement. SQL injection through strings is likely to be caught much earlier, +# since that will generate a syntax error if the string is not properly escaped +# (and who'd put effort into escaping strings when placeholders are easier?). +sub interp_warn { + my @r = sql_interp @_; + carp "Possible SQL injection in '$r[0]'" if tuwf->debug && $r[0] =~ /[2-9]/; # 0 and 1 aren't interesting, "SELECT 1" is a common pattern and so is "x > 0" + return @r; +} + + +# SQL::Interp wrappers around TUWF's db* methods. These do not work with +# sql_type(). Proper integration should probably be added directly to TUWF. +sub TUWF::Object::dbExeci { shift->dbExec(interp_warn @_) } +sub TUWF::Object::dbVali { shift->dbVal (interp_warn @_) } +sub TUWF::Object::dbRowi { shift->dbRow (interp_warn @_) } +sub TUWF::Object::dbAlli { shift->dbAll (interp_warn @_) } +sub TUWF::Object::dbPagei { shift->dbPage(shift, interp_warn @_) } + +# Ugly workaround to ensure that db* method failures are reported at the actual caller. +$Carp::Internal{ (__PACKAGE__) }++; + + + +# 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], ')'; +} + + + + +# The enrich*() functions are based on https://dev.yorhel.nl/doc/sqlobject +# See that article for general usage information, the following is purely +# reference documentation: +# +# enrich $name, $key, $merge_col, $sql, @objects; +# +# Add a $name field each item in @objects, +# Its value is a (possibly empty) array of hashes with data from $sql, +# +# enrich_flatten $name, $key, $merge_col, $sql, @objects; +# +# Add a $name field each item in @objects, +# Its value is a (possibly empty) array of values from a single column from $sql, +# +# enrich_merge $key, $sql, @objects; +# +# Merge all columns returned by $sql into @objects; +# +# +# Arguments: +# +# $key is the field in @objects used in the IN clause of $sql, +# +# $merge_col is the column name returned by $sql and compared against the +# values of the $key field. +# (enrich_merge() requires that the column name is equivalent to $key) +# +# $sql is the query to be executed, can be either: +# - A string or sql() object, in which case it should end with ' IN' so +# that the list of identifiers can be appended to it. +# - A subroutine, in which case the array of identifiers is given as first +# argument. The sub should return an sql() object. +# +# @objects is a list or array of hashrefs to be enriched. + + +# 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); +} + + +sub enrich { + my($name, $key, $merge_col, $sql, @array) = @_; + _enrich sub { + my($data, $array) = @_; + my %ids = (); + push $ids{ delete $_->{$merge_col} }->@*, $_ for @$data; + $_->{$name} = $ids{ $_->{$key} }||[] for @$array; + }, $key, $sql, @array; +} + + +sub enrich_merge { + my($key, $sql, @array) = @_; + _enrich sub { + my($data, $array) = @_; + my %ids = map +(delete($_->{$key}), $_), @$data; + %$_ = (%$_, $ids{ $_->{$key} }->%*) for @$array; + }, $key, $sql, @array; +} + + +sub enrich_flatten { + my($name, $key, $merge_col, $sql, @array) = @_; + _enrich sub { + my($data, $array) = @_; + my %ids = (); + push $ids{ delete $_->{$merge_col} }->@*, values %$_ for @$data; + $_->{$name} = $ids{ $_->{$key} }||[] for @$array; + }, $key, $sql, @array; +} + + +1; |