summaryrefslogtreecommitdiff
path: root/lib/VNWeb/DB.pm
diff options
context:
space:
mode:
authorYorhel <git@yorhel.nl>2019-09-17 20:26:09 +0200
committerYorhel <git@yorhel.nl>2019-09-17 20:28:55 +0200
commitcc2a1d72e499f7befe1b615a1322952dfb628fab (patch)
tree19ebe2931d082453d7004894da8259014ce23ca4 /lib/VNWeb/DB.pm
parentb34b37ba5acdf423ab30f4927cbdbbc704e91590 (diff)
v2rw: Initial start on an incremental rewrite; Layout HTML first
I copied and modified VN3::DB to VNWeb::DB, but it isn't used yet. Now that I think about it, that module isn't "web" specific at all and should perhaps be in the VNDB:: namespace. Oh well.
Diffstat (limited to 'lib/VNWeb/DB.pm')
-rw-r--r--lib/VNWeb/DB.pm180
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;