Daizu::Util - various utility functions

package Daizu::Util;
use warnings;
use strict;

use base 'Exporter';
our @EXPORT_OK = qw(
    trim trim_with_empty_null like_escape pgregex_escape url_encode url_decode
    validate_number validate_uri validate_mime_type
    validate_date w3c_datetime db_datetime rfc2822_datetime parse_db_datetime
    display_byte_size
    db_row_exists db_row_id db_select db_select_col
    db_insert db_update db_replace db_delete transactionally
    wc_file_data guess_mime_type wc_set_file_data mint_guid
    guid_first_last_times get_subversion_properties
    load_class instantiate_generator
    update_all_file_urls aggregate_map_changes
    add_xml_elem xml_attr xml_croak expand_xinclude
    branch_id daizu_data_dir
);

use URI;
use DateTime;
use DateTime::Format::Pg;
use DBD::Pg;
use File::MMagic;
use Path::Class qw( file );
use Digest::SHA1 qw( sha1_base64 );
use Image::Size qw( imgsize );
use Math::Round qw( nearest );
use XML::LibXML;
use Encode qw( encode decode );
use Carp qw( croak );
use Carp::Assert qw( assert DEBUG );

sub trim
{
    my ($s) = @_;
    return unless defined $s;
    $s =~ s/^\s+//;
    $s =~ s/\s+\z//;
    return $s;
}

sub trim_with_empty_null
{
    my ($s) = @_;
    return unless defined $s;
    $s =~ s/^\s+//;
    return if $s eq '';
    $s =~ s/\s+\z//;
    return $s;
}

sub like_escape
{
    my ($s) = @_;
    return unless defined $s;
    $s =~ s/([\\_%])/\\$1/g;
    return $s;
}

sub pgregex_escape
{
    my ($s) = @_;
    return unless defined $s;
    $s =~ s/([.^\$+*?()\[\]{\\])/\\$1/g;
    return $s;
}

sub url_encode
{
    my ($s) = @_;
    $s = encode('UTF-8', $s, Encode::FB_CROAK);

    $s =~ s{([^-.,/_a-zA-Z0-9 ])}{sprintf('%%%02X', ord $1)}ge;
    $s =~ tr/ /+/;

    return decode('UTF-8', $s, Encode::FB_CROAK);
}

sub url_decode
{
    my ($s) = @_;
    $s = encode('UTF-8', $s, Encode::FB_CROAK);

    $s =~ tr/+/ /;
    $s =~ s/%([\da-fA-F]{2})/chr hex $1/eg;

    return decode('UTF-8', $s, Encode::FB_CROAK);
}

sub validate_number
{
    my ($num) = @_;
    return unless $num =~ /\A(\d+)\z/;
    return $1;
}

sub validate_uri
{
    my ($uri) = @_;
    $uri = trim($uri);
    return undef unless defined $uri;

    # Check for illegal characters.
    return undef if $uri =~ /[^-a-zA-Z0-9:\/?#[\]@!\$&'()*+,;=._~]/;

    my ($scheme, $authority, $path, $query) = $uri =~ m{
                \A
                (?: ([a-zA-Z][-+.a-zA-Z0-9]*) :)    # scheme (required)
                (?: // ([^/?#]*) )?                 # authority (optional)
                ([^?#]*)                            # path (including domain, etc.)
                (?: \? ([^#]*) )?                   # query string (optional)
                (?: \# .* )?                        # fragment (optional)
                \z
        }x;
    return undef unless defined $scheme;

    # If authority is present, the path must be empty or begin with a '/'.
    if (defined $authority && length $authority) {
        return undef unless $path eq '' || $path =~ m!^/!;
    }
    else {
        # If authority is not present, the path must not start with '//'.
        return undef if $path =~ m!^//!;
    }

    return URI->new($uri);
}

sub validate_mime_type
{
    my ($s) = @_;
    return unless defined $s;
    return unless $s =~ m{
                \A (
                [-!#$%&'*+.0-9A-Z^_`a-z{|}~]+
                \/
                [-!#$%&'*+.0-9A-Z^_`a-z{|}~]+
                )\z
        }x;
    return lc $1;
}

sub validate_date
{
    my ($s) = @_;
    return unless defined $s;
    return unless $s =~ m{
                ^\s*
                (\d\d\d\d)-(\d\d)-(\d\d)
                T
                (\d\d):(\d\d):(\d\d)(\.\d+)?
                Z
                \s*$
        }ix;
    return DateTime->new(
        year => $1,
        month => $2,
        day => $3,
        hour => $4,
        minute => $5,
        second => $6,
        (defined $7 ? (nanosecond => $7 * 1_000_000_000) : ()),
        time_zone => 'UTC',
    );
}

sub w3c_datetime
{
    my ($dt, $include_micro) = @_;
    $dt = validate_date($dt) unless ref $dt;
    return undef unless defined $dt;
    $include_micro = 0 if $include_micro && $dt->nanosecond == 0;
    return $dt->strftime('%FT%T' . ($include_micro ? '.%6NZ' : 'Z'));
}

sub db_datetime
{
    my ($dt) = @_;
    $dt = validate_date($dt) unless ref $dt;
    return undef unless defined $dt;
    return DateTime::Format::Pg->format_datetime($dt);
}

sub rfc2822_datetime
{
    my ($dt) = @_;
    $dt = validate_date($dt) unless ref $dt;
    return undef unless defined $dt;
    return $dt->strftime('%a, %d %b %Y %H:%M:%S %z');
}

sub parse_db_datetime
{
    my ($dt) = @_;
    return undef unless defined $dt;
    return DateTime::Format::Pg->parse_datetime($dt);
}

{
    use constant K => 1024;
    use constant M => K * K;
    use constant G => M * K;

    sub display_byte_size
    {
        my ($bytes) = @_;

        return "${bytes}b"
            if $bytes < K;
        return nearest(1, $bytes / K) . 'Kb'
            if $bytes < M;
        return nearest(0.1, $bytes / M) . 'Mb'
            if $bytes < G;
        return nearest(0.01, $bytes / G) . 'Gb';
    }
}

# Used by some of the database utility functions to generate SQL 'where'
# clauses.
# Warning: don't use this when values might contain arbitrary binary data.
sub _where
{
    my $db = shift;
    return '' unless @_;

    return 'where id = ' . $db->quote(@_) if @_ == 1;

    my %condition = @_;
    return 'where ' . join ' and ',
                      map {
                          my $value = $condition{$_};
                          defined $value ? "$_ = " . $db->quote($value)
                                         : "$_ is null";
                      }
                      keys %condition;
}

sub db_row_exists
{
    my ($db, $table, @where) = @_;
    my $where = _where($db, @where);

    return $db->selectrow_array(qq{
                select 1
                from $table
                $where
                limit 1
        });
}

sub db_row_id
{
    my ($db, $table, @where) = @_;
    my $where = _where($db, @where);

    return $db->selectrow_array(qq{
                select id
                from $table
                $where
                limit 1
        });
}

sub db_select
{
    my ($db, $table, $where, @columns) = @_;
    croak 'usage: db_select($db, $table, $where, @columns)'
        unless @columns;

    my $columns = join ', ', @columns;
    $where = _where($db, (ref $where ? (%$where) : ($where)));

    return $db->selectrow_array(qq{
                select $columns
                from $table
                $where
                limit 1
        });
}

sub db_select_col
{
    my ($db, $table, $where, $column) = @_;
    croak 'usage: db_select_col($db, $table, $where, $column)'
        unless @_ == 4 && defined $column;

    $where = _where($db, (ref $where ? (%$where) : ($where)));

    my $records = $db->selectcol_arrayref(qq{
                select $column
                from $table
                $where
        });

    return @$records;
}

sub db_insert
{
    my ($db, $table, %value) = @_;
    croak 'usage: db_insert($db, $table, %value)'
        unless keys %value;

    my $columns = join ', ', keys %value;
    my $placeholders = join ', ', ('?') x scalar keys %value;
    $db->do("insert into $table ($columns) values ($placeholders)",
             undef, values %value);

    # Return the ID of the new value, unless we're in void context.
    return unless defined wantarray;
    return $db->last_insert_id(undef, undef, $table, undef);
}

sub db_update
{
    my ($db, $table, $where, %value) = @_;
    return unless keys %value;

    if (ref $where) {
        croak 'db_update() without any conditions is too dangerous'
            unless keys %$where;
        $where = _where($db, %$where);
    }
    else {
        $where = 'where id = ' . $db->quote($where);
    }
    assert($where) if DEBUG;

    my $sets = join ', ',
               map { "$_ = " . $db->quote($value{$_}) }
               keys %value;

    return $db->do("update $table set $sets $where");
}

sub db_replace
{
    my ($db, $table, $where, %value) = @_;
    croak 'usage: db_replace($db, $table, $where, %value)'
        unless ref $where && keys %value;
    croak 'db_replace() without any conditions is too dangerous'
        unless keys %$where;

    if (db_row_exists($db, $table, %$where)) {
        db_update($db, $table, $where, %value);
        return undef;
    }
    else {
        while (my ($column, $value) = each %$where) {
            $value{$column} = $value
                unless exists $value{$column};
        }
        return db_insert($db, $table, %value);
    }
}

sub db_delete
{
    my ($db, $table, @where) = @_;
    croak 'db_delete() without any conditions is too dangerous'
        unless @where;

    my $where = _where($db, @where);
    assert($where) if DEBUG;

    return $db->do("delete from $table $where");
}

{
    # This is required to keep track of whether we're in a transaction already.
    # The keys are the stringifications of database handles, just in case
    # you're using this with more than one handle.
    my %level;

    sub transactionally
    {
        my ($db, $code, @args) = @_;

        my $in_transaction = $level{$db};
        ++$level{$db};

        $db->begin_work unless $in_transaction;

        # Call the code, using the same context as we were called in.
        my @ret;
        if (wantarray) {
            @ret = eval { $code->(@args) };
        }
        elsif (defined wantarray) {
            $ret[0] = eval { $code->(@args) };
        }
        else {
            eval { $code->(@args) };
        }

        if ($in_transaction) {
            --$level{$db};
        }
        else {
            delete $level{$db};
        }

        if ($@) {
            $db->rollback unless $in_transaction;
            die $@;
        }

        $db->commit unless $in_transaction;

        return wantarray ? @ret : $ret[0];
    }
}

sub wc_file_data
{
    my ($db, $file_id) = @_;
    assert(defined $file_id) if DEBUG;

    my ($is_dir, $data, $data_ref_id) = db_select($db,
        wc_file => $file_id,
        qw( is_dir data data_from_file_id ),
    );
    assert(!$is_dir) if DEBUG;

    if (!defined $data) {
        croak "no data for file $file_id"
            unless defined $data_ref_id;
        $data = db_select($db, wc_file => $data_ref_id, 'data');
    }

    return \$data;
}

sub guess_mime_type
{
    my ($data, $filename) = @_;
    my $mime_magic = File::MMagic->new;
    my $mime_type = $mime_magic->checktype_contents($$data);
    return unless defined $mime_type;

    $mime_type =~ /^[-a-z0-9]+\/[-a-z0-9]+$/i
        or croak "got invalid mime type for '$filename' ($mime_type)";
    $mime_type = 'text/css'
        if $mime_type eq 'text/plain' && defined $filename &&
           $filename =~ /\.css$/i;

    return $mime_type;
}

sub guid_first_last_times
{
    my ($db, $guid_id) = @_;
    my ($first, $last) = db_select($db, file_guid => $guid_id,
                                   qw( first_revnum last_changed_revnum ));
    my ($issued) = db_select($db, revision => { revnum => $first },
                             'committed_at');
    my ($modified) = db_select($db, revision => { revnum => $last },
                               'committed_at');
    return (parse_db_datetime($issued), parse_db_datetime($modified));
}

sub get_subversion_properties
{
    my ($ra, $path, $revnum) = @_;

    my $stat = $ra->stat($path, $revnum);
    return undef unless defined $stat;

    # When accessing a remote repository the 'get_file' method doesn't
    # work on directories, although for some reason it does with a local
    # 'file:' repository.
    my $props;
    if ($stat->kind == $SVN::Node::dir) {
        (undef, undef, $props) = $ra->get_dir($path, $revnum);
    }
    else {
        (undef, $props) = $ra->get_file($path, $revnum, undef);
    }

    return $props;
}

# TODO - if this changes the mime type, it should update the wc_property table
sub wc_set_file_data
{
    my ($cms, $wc_id, $file_id, $content_type, $data, $allow_data_ref) = @_;
    my $db = $cms->{db};

    my ($img_wd, $img_ht);
    ($img_wd, $img_ht) = imgsize($data)
        if defined $content_type && $content_type =~ m!^image/!i;

    my $sha1 = sha1_base64($$data);
    my $live_wc_id = $cms->{live_wc_id};

    # Working copies other than the live one can reference a file in the
    # live working copy which has the same data, rather than storing a
    # separate copy of it.
    my $saved;
    if (length($$data) > 0 && $wc_id != $live_wc_id && $allow_data_ref) {
        my ($src_file_id) = $db->selectrow_array(q{
                        select id
                        from wc_file
                        where wc_id = ?
                            and data is not null
                            and data_sha1 = ?
                            and data_len = ?
                }, undef, $live_wc_id, $sha1, length($$data));
        if (defined $src_file_id) {
            db_update($db, wc_file => $file_id,
                data => undef,
                data_from_file_id => $src_file_id,
                data_sha1 => $sha1,
                data_len => length($$data),
                image_width => $img_wd,
                image_height => $img_ht,
            );
            $saved = 1;
        }
    }
    elsif ($wc_id == $live_wc_id) {
        # When the live working copy's data is updated, make sure there
        # aren't any other files which reference the old version of the
        # data.  If there are, give them a full copy.
        $db->do(q{
                        update wc_file
                        set data = (select data from wc_file where id = ?),
                                data_from_file_id = null
                        where data_from_file_id = ?
                }, undef, $file_id, $file_id);
    }

    # Store the new content.
    if (!$saved) {
        my $sth = $db->prepare(q{
                        update wc_file
                        set data = ?,
                                data_len = ?,
                                data_sha1 = ?,
                                data_from_file_id = null,
                                image_width = ?,
                                image_height = ?
                        where id = ?
                });
        $sth->bind_param(1, $$data, { pg_type => DBD::Pg::PG_BYTEA });
        $sth->bind_param(2, length $$data);
        $sth->bind_param(3, $sha1);
        $sth->bind_param(4, $img_wd);
        $sth->bind_param(5, $img_ht);
        $sth->bind_param(6, $file_id);
        $sth->execute;
    }
}

sub mint_guid
{
    my ($cms, $is_dir, $path, $revnum) = @_;
    my $db = $cms->{db};

    return transactionally($db, sub {
        my $guid_id = db_insert($db, file_guid =>
            is_dir => ($is_dir ? 1 : 0),
            uri => 'x-temp:',
            first_revnum => $revnum,
            last_changed_revnum => $revnum,
        );

        my $entity = $cms->guid_entity($path);
        my $guid_uri = "tag:$entity:$guid_id";
        db_update($db, file_guid => $guid_id,
            uri => $guid_uri,
        );

        return ($guid_id, $guid_uri);
    });
}

{
    my %class_loaded;

    sub load_class
    {
        my ($class) = @_;
        unless (exists $class_loaded{$class}) {
            eval "require $class";
            die "$@" if $@;
            undef $class_loaded{$class};
        }
    }
}

sub instantiate_generator
{
    my ($cms, $class, $root_file) = @_;

    $class = 'Daizu::Gen'
        unless defined $class;

    load_class($class);

    my $path = $root_file->{path};
    my $config = $cms->{generator_config}{$class}{$path};
    $config = $cms->{generator_config}{$class}{''}
        unless defined $config;

    return $class->new(
        cms => $cms,
        root_file => $root_file,
        config_elem => $config,
    );
}

sub update_all_file_urls
{
    my ($cms, $wc_id) = @_;
    my $db = $cms->{db};

    return transactionally($db, sub {
        my $sth = $db->prepare(q{
                        select id
                        from wc_file
                        where wc_id = ?
                });
        $sth->execute($wc_id);

        # These are aggregate versions of the same variables as in the
        # update_urls_in_db() function in Daizu::File.  Look there for
        # details of what they mean.
        my (%redirects_changed, %gone_changed);

        my %dup_urls;
        while (my ($file_id) = $sth->fetchrow_array) {
            my $file = Daizu::File->new($cms, $file_id);
            my $changes = $file->update_urls_in_db(\%dup_urls);

            aggregate_map_changes($changes, \%redirects_changed,
                                  \%gone_changed);
        }

        resolve_url_update_duplicates($db, $wc_id, \%dup_urls);

        # Any other active URLs which belong to files that no longer exist
        # should be deactivated.
        $db->do(q{
                        update url
                        set status = 'G'
                        where wc_id = ?
                            and guid_id in (
                                select u.guid_id
                                from url u
                                left outer join wc_file f on f.wc_id = u.wc_id and
                                                                                          f.guid_id = u.guid_id
                                where u.wc_id = ?
                                    and u.status = 'A'
                                    and f.id is null
                            )
                }, undef, $wc_id, $wc_id);

        return {
            update_redirect_maps => \%redirects_changed,
            update_gone_maps => \%gone_changed,
        };
    });
}

sub resolve_url_update_duplicates
{
    my ($db, $wc_id, $dup_urls) = @_;

    # If there are any new active URLs which still clash with old
    # active ones, the old ones may belong to files which no longer
    # exist in the working copy.  Either way, resolve the duplicates.
    while (my ($url, $dup) = each %$dup_urls) {
        my $orig_guid_id = db_select($db, url => $dup->{id}, 'guid_id');
        my $file_still_exists = db_row_exists($db, 'wc_file',
            wc_id => $wc_id,
            guid_id => $orig_guid_id,
        );

        if ($file_still_exists) {
            croak "new URL '$url' would conflict with existing URL";
        }
        else {
            db_update($db, url => $dup->{id},
                guid_id => $dup->{guid_id},
                generator => $dup->{generator},
                method => $dup->{method},
                argument => $dup->{argument},
                content_type => $dup->{type},
            );
        }
    }
}

sub aggregate_map_changes
{
    my ($changes, $redirects_changed, $gone_changed) = @_;

    while (my ($file, $conf) = each %{$changes->{update_redirect_maps}}) {
        next if exists $redirects_changed->{$file};
        $redirects_changed->{$file} = $conf;
    }

    while (my ($file, $conf) = each %{$changes->{update_gone_maps}}) {
        next if exists $gone_changed->{$file};
        $gone_changed->{$file} = $conf;
    }
}

sub add_xml_elem
{
    my ($parent, $name, $content, %attr) = @_;
    my $elem = XML::LibXML::Element->new($name);
    $parent->appendChild($elem);

    if (defined $content) {
        $content = XML::LibXML::Text->new($content)
            unless ref $content;
        $elem->appendChild($content);
    }

    while (my ($attr_name, $value) = each %attr) {
        $elem->setAttribute($attr_name => $value);
    }

    return $elem;
}

sub xml_attr
{
    my ($filename, $elem, $attr, $default) = @_;
    return $elem->getAttribute($attr)
        if $elem->hasAttribute($attr);
    return $default
        if defined $default;

    my $elem_name = $elem->localname;
    xml_croak($filename, $elem,
              "missing attribute '$attr' on element <$elem_name>");
}

sub xml_croak
{
    my ($filename, $node, $msg) = @_;
    my $line_number = $node->line_number;
    croak "$filename:$line_number: $msg";
}

sub expand_xinclude
{
    my ($db, $doc, $wc_id, $path) = @_;

    my $parser = XML::LibXML->new;
    $parser->expand_xinclude(1);

    my @included_file;

    my $input_callbacks = XML::LibXML::InputCallback->new;
    $input_callbacks->register_callbacks([
        \&_match_uri,
        sub { _open_uri($db, $wc_id, \@included_file, @_) },
        \&_read_uri,
        \&_close_uri,
    ]);
    $parser->input_callbacks($input_callbacks);

    my $root = $doc->documentElement;
    $root->setAttribute('xml:base' => 'daizu:///' . url_encode($path))
        unless $root->hasAttribute('xml:base');

    $parser->process_xincludes($doc);

    return @included_file;
}

# This set of callback functions are used to handle the special non-standard
# 'daizu:' URI scheme for loading file content from the working copy the
# article file comes from.
# Other URI schemes are disallowed for security reasons.
sub _match_uri
{
    my ($uri) = @_;
    croak "articles may only use XInclude for 'daizu:' URIs, not '$uri'"
        unless $uri =~ /^daizu:/i;
    return 1;
}

sub _open_uri
{
    my ($db, $wc_id, $included_file, $uri) = @_;

    my $path = $uri;
    $path =~ s!^daizu:/*!!i;
    my ($file_id, $is_dir) = db_select($db, 'wc_file',
        { wc_id => $wc_id, path => $path },
        qw( id is_dir ),
    );
    croak "can't read '$uri' included with XInclude, it's a directory"
        if $is_dir;

    my $data = wc_file_data($db, $file_id);
    open my $fh, '<', $data
        or die "error opening in-memory file to read '$uri': $!";

    push @$included_file, $file_id;
    return $fh;
}

sub _read_uri
{
    my ($fh, $length) = @_;
    my $buffer;
    my $ret = read $fh, $buffer, $length;
    die "error reading from file: $!"
        unless defined $ret;
    return $buffer;
}

sub _close_uri
{
    my ($fh) = @_;
    close $fh;
}

sub branch_id
{
    my ($db, $branch) = @_;
    return $1 if $branch =~ /^(\d+)$/;

    my $branch_id = db_row_id($db, 'branch', path => $branch);
    croak "branch '$branch' does not exist"
        unless defined $branch_id;

    return $branch_id;
}

sub daizu_data_dir
{
    my ($dir) = @_;
    my $path = file(__FILE__)->dir->subdir($dir)->absolute;
    die "data directory '$dir' not found at '$path' where it should be"
        unless -d $path;
    return $path;
}

1;
# vi:ts=4 sw=4 expandtab