Infrastructure

#!/usr/bin/perl -T

use v5.10;

use strict;

use warnings;

use threads;

use threads::shared;

use Thread::Queue ();

BEGIN {

    # JSON::XS is not thread-safe...

    $ENV{PERL_JSON_BACKEND} = "Cpanel::JSON::XS";

}

use Config::Tiny ();

use Crypt::URandom qw/urandom/;

use DBI qw/:sql_types/;

use Encode ();

use File::Basename qw/basename dirname/;

use JSON ();

use LWP::MediaTypes qw/guess_media_type/;

use LWP::UserAgent ();

use POSIX ();

use URI::Escape qw/uri_escape_utf8/;

use Time::HiRes qw/usleep/;

my $SCRIPT_FILENAME = $0 =~ /\A(\p{Graph}+)\z/ ? $1 : die;

my $CONF = Config::Tiny::->read("$SCRIPT_FILENAME.conf") or die Config::Tiny::->errstr()."\n";

my ($DBH, $ASKBOT, $DISCOURSE, $WORKER, $INDENT);

my ($DISCOURSE_TIME, $DISCOURSE_COUNT, $ASKBOT_TIME, $ASKBOT_COUNT);

my $NUM_WORKERS = 8;

#######################################################################

# Logging

open my $LOG, ">", "$SCRIPT_FILENAME.log" or die "open($SCRIPT_FILENAME.log): $!";

sub logmsg($@) {

    my $level = shift;

    my @msg = @_;

    $_ = Encode::encode("UTF-8", $_) foreach @msg;

    my $level2 = $level eq "SOFTFAIL" ? "ERROR" : $level;

    unshift @msg, $level2, " ";

    unshift @msg, sprintf("[%0*d] ", length($NUM_WORKERS), $WORKER) if defined $WORKER;

    push @msg, "\n";

    $LOG->printflush( POSIX::strftime("%b %d %H:%M:%S ", localtime), @msg );

    if ($level eq "WARN" or $level eq "NOTICE" or $level eq "SOFTFAIL") {

        print STDERR @msg;

    } elsif ($level eq "PANIC" or $level eq "ERROR") {

        die @msg;

    }

}

sub fail(@) {

    return logmsg(ERROR => @_);

}

sub panic(@) {

    my @msg = @_;

    my @loc = caller;

    push @msg, " " if @msg;

    push @msg, "at line $loc[2] in $loc[1]";

    return logmsg(PANIC => @msg);

}

# useragent_init()

#   (Re-)init user agent, incl. connection cache.

sub useragent_init() {

    $ASKBOT = LWP::UserAgent::->new(

        keep_alive => 1,

        ssl_opts => { verify_hostname => 1, SSL_hostname => $CONF->{askbot}->{host} },

        default_headers => HTTP::Headers::->new()

    );

    $DISCOURSE = LWP::UserAgent::->new(

        keep_alive => 1,

        ssl_opts => { verify_hostname => 1 },

        default_headers => HTTP::Headers::->new(

            "Accept" => "application/json",

            "Api-Key" => $CONF->{discourse}->{apikey}

        )

    );

    ($DISCOURSE_TIME, $DISCOURSE_COUNT, $ASKBOT_TIME, $ASKBOT_COUNT) = (0,0,0,0);

}

# decode_json_response($AGENT => $RESPONSE)

#   Decode an application/json HTTP response.  If a 5XY HTTP response

#   was received, try again to send the request with a 1min timeout.

sub decode_json_response($$;$);

sub decode_json_response($$;$) {

    my ($ua, $resp, $timeout) = @_;

    if ($resp->is_success) {

        my $data = $resp->decoded_content();

        return JSON::->new->utf8->decode($data);

    }

    my $code = $resp->code();

    my $req = $resp->request();

    # random delay between 0.75 and 1.25 seconds to help solving race conditions

    # between threads

    $timeout = defined $timeout ? ($timeout * 2) : (int(rand(500_000)) + 750_000);

    if ($code >= 500 and $code <= 599 and $timeout <= 320_000_000) {

        # upon 5XY response codes, retry up to 5 minutes

        logmsg(INFO => "Received $code from <", $req->uri(), ">; ",

            "will retry in ", int($timeout/1000), "ms");

        usleep($timeout);

        return decode_json_response($ua => $ua->request($req), $timeout);

    }

    my @error = ($resp->status_line(), " ", $req->method(), " <", $req->uri(), ">");

    my $content_type = $resp->content_type();

    if ($content_type eq "application/json") {

        my $content = $resp->decoded_content();

        chomp $content;

        push @error, " ", $content;

    }

    fail(@error);

}

# askbot_get($URL)

#   Send a request to the AskBot API and decode the JSON response.

sub askbot_get($) {

    my $url = $CONF->{askbot}->{apiurl} . shift;

    my $t0 = Time::HiRes::gettimeofday();

    my $resp = $ASKBOT->get($url, Host => $CONF->{askbot}->{host}, Accept => "application/json");

    $ASKBOT_TIME += Time::HiRes::gettimeofday() - $t0;

    $ASKBOT_COUNT++;

    return decode_json_response($ASKBOT => $resp);

}

# discourse_req($USERNAME, $METHOD, $PATH, [$BODY])

#   Send a request to the Discourse API and decode the JSON response.

sub discourse_req($$$;$) {

    my ($username, $method, $path, $body) = @_;

    my $req = HTTP::Request::->new( $method => $CONF->{discourse}->{apiurl} . $path );

    $req->header( Host => $CONF->{discourse}->{host} );

    # the API doesn't mention case for usernames, but seems we need it

    # for some Unicode usernames...

    $req->header( "Api-Username" => Encode::encode("UTF-8", lc($username)) );

    if (defined $body) {

        $req->content_type("application/json");

        $req->content(JSON::->new->utf8->encode($body));

    }

    my $t0 = Time::HiRes::gettimeofday();

    my $resp = $DISCOURSE->request($req);

    $DISCOURSE_TIME += Time::HiRes::gettimeofday() - $t0;

    $DISCOURSE_COUNT++;

    return decode_json_response($DISCOURSE => $resp);

}

# upload($USERNAME, $PATH, type => $TYPE, ...)

#   Download $PATH from AskBot and re-upload to Discourse; returns the

#   upload response from the Discourse API, cf.

#   https://docs.discourse.org/#tag/Uploads/paths/~1uploads.json/post

#

#   If the download yields 404 then returns undef instead.

sub upload($$%) {

    my $username = shift;

    my $path = shift;

    my %attrs = @_;

    my $filename = delete $attrs{filename} // basename($path);

    my $content_type = guess_media_type($filename);

    logmsg(INFO => "    " x $INDENT, "upload $path ($filename)");

    panic($path) unless $path =~ /\A\//;

    my $uri = $CONF->{askbot}->{apiurl} . $path;

    my $t0 = Time::HiRes::gettimeofday();

    my $resp = $ASKBOT->get($uri, Host => $CONF->{askbot}->{host}) or panic();

    $ASKBOT_TIME += Time::HiRes::gettimeofday() - $t0;

    $ASKBOT_COUNT++;

    unless ($resp->is_success) {

        my @error = ($resp->status_line(), " <", $uri, ">");

        if ($resp->code() == 404) {

            logmsg(WARN => @error);

            return;

        } else {

            panic(@error);

        }

    }

    # RFC 1867, using HTTP::Request::Common's form_ref

    my @form_data = ( undef, Encode::encode("UTF-8", $filename) );

    push @form_data, "Content-type" => $content_type

                   ,  Content => $resp->decoded_content();

    my $t1 = Time::HiRes::gettimeofday();

    $resp = $DISCOURSE->post( $CONF->{discourse}->{apiurl} . "/uploads.json",

        "Api-Username" => Encode::encode("UTF-8", lc($username)),

        Host => $CONF->{discourse}->{host},

        Content_Type => "form-data",

        Content => [ %attrs, synchronous => "true", "files[]" => \@form_data ]

    );

    $DISCOURSE_TIME += Time::HiRes::gettimeofday() - $t1;

    $DISCOURSE_COUNT++;

    return decode_json_response($DISCOURSE => $resp);

}

# username($ID)

#   Returns the Discourse username associated with the AskBot user ID.

#   The Discourse user is created if it doesn't already exist.

my %ASKBOT_PROFILES; # pre-existing AskBot profiles, incl. SSO linking information

my %ASKBOT_DUPLICATES;

my %DISCOURSE_PROFILES; # map AskBot user ID -> Discourse profile

sub username($);

sub username($) {

    my $orig_id = shift;

    my $id = $ASKBOT_DUPLICATES{$orig_id} // $orig_id;

    state $sth_user_lookup = $DBH->prepare(q{

        SELECT username FROM users WHERE id = ?

    });

    my $profile = $ASKBOT_PROFILES{$id} // fail("Can't find user #$id in users.json");

    my $username = $profile->{discourse_username} // panic($id);

    my ($u, $user_id);

    {

        my $p = $DISCOURSE_PROFILES{$id} // panic($id);

        lock(%$p); # only need to lock that user's profile

        return $username if exists $p->{user_id}; # already created

        # user API is not localized, let's stick to english

        $u = askbot_get("/en/api/v1/users/$id/");

        my $msg = $profile->{username};

        $msg .= " -> $username" if $username ne $profile->{username};

        $msg .= ", duplicate #$orig_id" if $id != $orig_id;

        logmsg(INFO => "    " x $INDENT, "user #$id ($msg)");

        my $email = $profile->{email} // panic();

        if ($email =~ /\@(?:mailinator|trashmail)\.[a-z]+$/i

                or $email !~ /\@[0-9a-z\-]+(?:\.[0-9a-z\-]+)+$/i) {

            logmsg(WARN => "user #$id ($username) has invalid email address <$email>");

            # create the account for content attribution but lock them out

            $email = "noreply+$username\@documentfoundation.org";

        }

        my $r = discourse_req("system", POST => "/users.json", {

            username => $username

          , password => unpack("H*", urandom(32)) # XXX required even with SSO

          , name => $profile->{name} // ""

          , email => $email

          , active => JSON::true

          , approved => JSON::true

        });

        panic(JSON::->new->utf8->encode($r)) unless defined $r->{success} and $r->{success} == JSON::true;

        $user_id = $r->{user_id} // panic($id);

        $sth_user_lookup->bind_param(1, $user_id, SQL_INTEGER);

        $sth_user_lookup->execute();

        my ($username2) = $sth_user_lookup->fetchrow();

        $sth_user_lookup->finish();

        unless (defined $username2 and $username2 eq $username) {

            # there is a race condition causing PostgreSQL to sometimes abort the transaction:

            # Discourse reports the user as created but any attempt to use it as Api-Username fails

            logmsg(SOFTFAIL => "Couldn't create user #$orig_id ($profile->{username}), retrying...");

            return username($orig_id);

        }

        # assign a Trust Level to the newly created account, depending on the users's activity on

        # AskBot, in order to bootstrap the site

        my $tl = ($u->{reputation} >= 1000 and time - $u->{last_seen_at} <= 31557600) ? 4

               : ($u->{reputation} >= 250 and $u->{answers} >= 100 and time - $u->{last_seen_at} <= 31557600) ? 3

               : ($u->{answers} + $u->{comments} >= 100) ? 2

               : ($u->{questions} + $u->{answers} + $u->{comments} >= 5) ? 1

               : 0;

        # leave non-returning (less than 10 between creation and last seen date) users at TL0

        $tl = 0 if $u->{last_seen_at} - $u->{joined_at} < 864000;

        discourse_req("system", PUT => "/admin/users/$user_id/trust_level", { level => $tl })

            unless $tl == 0;

        $p->{user_id} = $user_id;

        $p->{trust_level} = $tl;

    } # account was created and TL assigned, we can release the lock on $DISCOURSE_PROFILES{$id}

    $INDENT++;

    # preserve avatar

    my %avatar_upload;

    my $username_escaped = uri_escape_utf8(lc($username));

    if ($u->{avatar} =~ m#^(?:(?:https?:)?//www\.gravatar\.com/avatar)?/#) {

        my $path = "/user_avatar/$username_escaped/refresh_gravatar.json";

        my $r = discourse_req($username, POST => $path, { username => $username });

        $avatar_upload{upload_id} = $r->{gravatar_upload_id};

        $avatar_upload{type} = "gravatar";

    } elsif ($u->{avatar} =~ s,^(?:(?:https?:)?//ask\.libreoffice\.org)?(/[^/?#][^?#]*).*,$1,i) {

        unless ($u->{avatar} eq "/m/default/media/images/nophoto.png") {

            $u->{avatar} =~ s#^(/upfiles/avatars/[^/]+)/resized/[0-9]+/([^/]+)$#$1/$2#;

            my $r = eval { upload($username, $u->{avatar}, type => "avatar", user_id => $user_id) };

            if ($@) {

                print STDERR $@; # already logged

            } else {

                $avatar_upload{upload_id} = $r->{id};

                $avatar_upload{type} = "uploaded";

            }

        }

    } else {

        logmsg(WARN => "$username: unknown avatar URL $u->{avatar}");

    }

    if (%avatar_upload) {

        my $errstr = "$username: Couldn't set avatar ($avatar_upload{type})";

        if (defined $avatar_upload{upload_id}) {

            my $path = "/u/$username_escaped/preferences/avatar/pick.json";

            my $r = eval { discourse_req($username, PUT => $path, \%avatar_upload) };

            unless (!$@ and defined $r->{success} and $r->{success} eq "OK") {

                print STDERR $@ if $@; # already logged

                $errstr .= ": " . $r->{message} if defined $r and defined $r->{message};

                logmsg(SOFTFAIL => $errstr);

            }

        } else {

            logmsg(WARN => $errstr);

        }

    }

    # database surgery: set created and last seen dates from AskBot

    state $sth_user_last = $DBH->prepare(q{

        UPDATE users SET created_at = to_timestamp(?), last_seen_at = to_timestamp(?)

        WHERE id = ?

    });

    $sth_user_last->bind_param(1, $u->{joined_at},    SQL_INTEGER);

    $sth_user_last->bind_param(2, $u->{last_seen_at}, SQL_INTEGER);

    $sth_user_last->bind_param(3, $user_id,           SQL_INTEGER);

    my $r = $sth_user_last->execute();

    panic($r) unless $r == 1;

    $INDENT--;

    return $username;

}

# mangle_post_upload($USERNAME, $TEXT => $PATH, $INLINE)

#   Return a Markdown string with given $TEXT and AskBot source link

#   (attachment or screeshot).  The source is downloaded and re-uploaded

#   to Discourse.

sub mangle_post_upload($$$$) {

    my ($username, $text, $path, $inline) = @_;

    my $filename;

    unless ($inline) {

        # fix ugly C:\fakepath\something cf. https://www.mediawiki.org/wiki/Special:Code/MediaWiki/83225

        $text =~ s/\AC:\\fakepath\\([^\\]+)\z/$1/;

        my $ext = $path =~ /[^.\/\\]\.([a-zA-Z](?:-?[a-zA-Z0-9])*)\z/ ? $1 : undef;

        $filename = !(defined $ext and $text =~ /[^.\/\\]\.\Q$ext\E\z/i) ? basename($path)

                  : $text =~ /\A[A-Z]:\\.*\\(.+)\z/ ? basename($1)

                  : basename($text);

        $filename =~ tr[\t\n\f\r ][     ]s;

    }

    my $u = eval { upload($username, $path, type => "composer", filename => $filename) };

    unless (!$@ and defined $u) {

        # 404 or fatal error, can't do better

        print STDERR $@ if $@; # already logged

        logmsg(SOFTFAIL => "Couldn't re-upload $path");

        return;

    }

    return $inline ? "![$text]($u->{short_url})" : "[$text|attachment]($u->{short_url})";

}

# mangle_post_internal_link($ID, $LINK, $FINAL, $REF)

#   Return appropriate replacement for AskBot internal $LINK in post $ID.

#   The 3rd argument is a boolean indicating whether the import is

#   ongoing or if we're at the final phase.

#   The 4rd argument is a reference to a variable that is is set to 1 if

#   $FINAL is false and the mangling couldn't proceeed because the

#   AskBot question hasn't been processed yet, or if $FINAL is true and

#   a suitable substitute was found.

my %URLMAP :shared; # map AskBot post ID -> Discourse URL

my %CATEGORY_IDs;   # map language code -> Discourse category

sub mangle_post_internal_link($$$$) {

    my ($post_id, $link, $final, $ref_rv) = @_;

    my $uri = $link;

    my $hash  = $uri =~ s/\#(.*)// ? $1 : "";

    my $query = $uri =~ s/\?(.*)// ? $1 : "";

    my $lang = $uri =~ m,^                        /(?:question|user)s? (?:/|$),x ? "en"

             : $uri =~ s,^/([\p{PosixAlnum}\-_]+)(/(?:question|user)s? (?:/|$)),$2,x ? $1

             : $uri =~ s,^/([\p{PosixAlnum}\-_]+) /?$,/questions/,x ? $1

             : undef;

    my $newlink;

    unless (defined $lang) {

        return unless $uri eq "" or $uri eq "/"; # can't do better

        return if $CONF->{discourse}->{baseurl} eq "https://ask.libreoffice.org" and $query eq "" and $hash eq "";

        $newlink = "/"; # site root (ignore query and hash)

    } elsif ($uri =~ s#^/users?/([0-9]+)(?:/|$)##) {

        # don't create accounts during the final phase

        return if $final;

        my $username = eval { username($1) };

        if ($@) {

            print STDERR $@; # already logged

            logmsg(SOFTFAIL => "Couldn't create user #$1");

            return;

        }

        $newlink = "/u/" . uri_escape_utf8(lc($username)); # profile URL

    } elsif ($uri =~ s#^/questions?/([0-9]+)(?:/|$)##) {

        my $id = $1;

        my $old_post_id =

            $hash  =~ /^post-id-([0-9]+)$/                        ? $1

          : $query =~ /(?:^|&)(?:answer|comment)=([0-9]+)(?:&|$)/ ? $1

          : $id;

        unless (defined ($newlink = $URLMAP{$old_post_id})) {

            if (!$final) {

                $$ref_rv = 1; # needs post mangling

            } else {

                logmsg(WARN => "#$post_id: Can't mangle <$link> (missing #$old_post_id)");

            }

            return;

        }

    } elsif ($uri =~ m#^/questions?/?$#) {

        my $c = $CATEGORY_IDs{$lang} // return;

        $newlink = "/c/$c->{slug}/$c->{id}";

    } elsif ($uri =~ m#^/questions?/ask/?$#) {

        my $c = $CATEGORY_IDs{$lang} // return;

        $newlink = "/new-topic?category=$c->{slug}";

    } elsif ($uri =~ m#^/users?/?$#) {

        $newlink = "/u";

    } else {

        return;

    }

    $$ref_rv = 1 if $final; # modified

    logmsg(DEBUG => "#$post_id: Mangling <$link> -> <$newlink>");

    return $CONF->{discourse}->{baseurl} . $newlink;

}

# mangle_post_internal_links($ID, $REF_TEXT, [$FINAL])

#   Mangle all internal question/answer/comment/user links.  The 3rd

#   argument is a boolean indicating whether the import is ongoing or if

#   we're at the final phase.

#   Return a boolean, which when $FINAL is false indicates whether the

#   post needs post-mangling during the final phase, and when $FINAL is

#   true indicates whether the input text was mangled.

sub mangle_post_internal_links($$;$) {

    my ($id, $text, $final) = @_;

    my $rv = 0;

    $$text =~ s#\b (?i:(?:https?:)//ask\.libreoffice\.org)

            ( / [^\P{Graph}!"'\(\)<>\[\]\`\{\}]+? )

            (?! [^\P{Graph}!"'\(\),\.<>\?\[\]\`\{\}] | [!',\.\?]\p{Graph} )

            # mangle_post_internal_link($id, $1, $final => \$rv) // $& #egx;

    if ($final or !$rv) {

        # note: the regexp is intentionally loose

        logmsg(WARN => "Post #$id contains dangling internal link <$_>") foreach

            $$text =~ m#\b(?i:(?:https?:)//ask\.libreoffice\.org)/(?![ctu]/)\S+#g;

    }

    return $rv;

}

# mangle_post($AUTHOR, $POST)

#   Mangle $POST->{text} in place:

#   * fix attachments and screenshots;

#   * fix link to other profiles, "normal" links, bare URLs, and @-addressing

#     (the target profile is created if it doesn't exist); and

#   * fix links to questions, answers and comments.

#   Return a boolean indicating whether the post needs further mangling

#   during the final phase.

sub mangle_post($$) {

    my ($author, $p) = @_;

    # fix attachments and screenshots (an empty link text is allowed for screenshots, and we also

    # allow it for atttachment since we append "|attachment")

    $p->{text} =~ s#!\[ ([^\[\]\(\)]*) \]\( (?i:(?:https?:)?//ask\.libreoffice\.org)? (/m/[\p{PosixAlnum}\-_]+/media/images/[^\[\]\(\)]+) \)#

            mangle_post_upload("system", $1 => $2, 1) // $& #egx; # NOTE: discourse does deduplication

    $p->{text} =~ s#(!)?\[ ([^\[\]\(\)]*) \]\( (?i:(?:https?:)?//ask\.libreoffice\.org)? (/upfiles/[^\[\]\(\)]+) \)#

            mangle_post_upload($author, $2 => $3, $1) // $& #egx;

    # NOTE: mangle_post_upload() can fail if it tries to upload the same document twice at the

    # same time (race condition on uniqueness constraint) -- we could retry but we don't care so

    # much since sidekiq will automatically fetch https://ask.libreoffice.org/upfiles/12345.png

    # locally and update the post accordingly

    # NOTE: the handful of bare links https://ask.libreoffice.org/upfiles/foobar.xyz are

    # untouched hence will 404

    # fix @-addressing; we can't match $p->{text} against /\@\w+/ here because AskBot

    # usernames may contain spaces... so we check for <a href="..."/> in the HTML instead

    my %user_ids;

    $user_ids{$_} = 1 foreach $p->{summary} =~ m#<a\s(?:[^<>]*\s)*?href=['"]

            (?i:(?:https?:)?//ask\.libreoffice\.org)? (?:/[\p{PosixAlnum}\-_]+)?

                /users?/([0-9]+)[/'"]#gsx;

    foreach my $id (keys %user_ids) {

        # we don't want duplicate resolution here

        my $profile = $ASKBOT_PROFILES{$id};

        unless (defined $profile) {

            logmsg(WARN => "#$id is not a known AskBot user, can't mangle its \@-addresses");

            next;

        }

        my $old_username = $profile->{username} // panic($id);

        my $new_username = eval { username($id) }; # might need to be created

        if ($@) {

            print STDERR $@; # already logged

            logmsg(SOFTFAIL => "Couldn't create user #$id");

            next;

        }

        $p->{text} =~ s/\@\Q$old_username\E (?! [\.\-]?[\p{Mark}_\p{Alnum}] )

                       /\@$new_username/gx

            unless $old_username eq $new_username;

    }

    # explicitely prefix AskBot base URL so we don't have to do the work twice

    $p->{text} =~ s#\[ ([^\[\]\(\)]+) \]\( (/[^\[\]\(\)]*) \)#[$1](https://ask.libreoffice.org$2)#gx;

    # replace [URL](URL) links with a bare URL when possible so Discourse can use

    # its own text for internal post links

    $p->{text} =~ s#\[ ((?i:https?:)?//[^\[\]\(\)]+) \]\( \1 \)

            (?! [!',\.\?]* [^\P{Graph}!"'\(\),\.<>\?\[\]\{\}] )#$1#gx;

    return mangle_post_internal_links($p->{id} => \$p->{text});

}

# ts2iso8601($TIMESTAMP)

#   Convert a timestamp to ISO 8601.

sub ts2iso8601($) {

    my $ts = 0 + shift;

    return POSIX::strftime("%Y-%m-%dT%H:%M:%SZ", gmtime($ts));

}

# replies(language_code => $LANG, topic_id => $ID, replies => [..], ..)

#   Recursively process the given replies under some topic ID.  The

#   parent post is indicated by the optional reply_to_post_number

#   attribute.

#   Return the number of replies that couldn't be posted, if any

my @NEEDS_POST_MANGLING :shared;

sub replies(%);

sub replies(%) {

    my %attrs = @_;

    my $post_type = defined $attrs{reply_to_post_number} ? "comment" : "answer";

    my $askbot_url = "/$attrs{language_code}/api/v1/${post_type}s/";

    state $sth_set_vote_count = $DBH->prepare(q{

        INSERT INTO post_custom_fields

            (post_id, name, value, created_at, updated_at)

            VALUES (?, 'vote_count', ?, NOW(), NOW())

    });

    my $num_errors = 0;

    my $indent_base = $INDENT;

    foreach my $id (sort {$a <=> $b} @{$attrs{replies}}) { # lowest ID first

        logmsg(INFO => "    " x $indent_base, "$post_type #$id");

        $INDENT = $indent_base + 1;

        my ($r, $t);

        eval {

            $r = askbot_get("$askbot_url$id/");

            my $author = username($r->{author}->{id});

            my $needs_post_mangling = mangle_post($author, $r);

            $t = discourse_req($author, POST => "/posts.json", {

                topic_id => $attrs{topic_id}

              , reply_to_post_number => $attrs{reply_to_post_number}

              , raw => $r->{text}

              , created_at => ts2iso8601($r->{added_at})

              , skip_validations => JSON::true

            });

            push @NEEDS_POST_MANGLING, $t->{id} if $needs_post_mangling;

        };

        if ($@) {

            print STDERR $@; # already logged

            logmsg(SOFTFAIL => "Couldn't post $post_type #$id");

            $num_errors++;

            next;

        }

        # no need to lock here, other threads will never store that ID

        $URLMAP{$r->{id}} = "/t/$t->{topic_slug}/$t->{topic_id}/$t->{post_number}";

        if ($post_type eq "answer") {

            # database surgery: set vote count on answers (skip

            # questions and comments as Discourse doesn't show these)

            if ((my $score = $r->{score}) > 0) {

                $sth_set_vote_count->bind_param(1, $t->{id}, SQL_INTEGER);

                $sth_set_vote_count->bind_param(2, $score,   SQL_INTEGER);

                my $r = $sth_set_vote_count->execute();

                panic($r) unless $r == 1;

            }

            if (defined $attrs{accepted_answer_id} and $attrs{accepted_answer_id} == $id) {

                # XXX rate-limiting is not configurable, need  to comment out

                # "limit_accepts" in plugins/discourse-solved/plugin.rb:accept

                logmsg(INFO => "    " x $INDENT, "accept answer #$id");

                $INDENT++;

                my $r = eval { discourse_req($attrs{accepted_by}, POST => "/solution/accept",

                                    { id => $t->{id} }) };

                if ($@) {

                    print STDERR $@; # already logged

                    logmsg(SOFTFAIL => "Couldn't accept answer #$id");

                } elsif (!defined $r->{success} or $r->{success} ne "OK") {

                    panic(JSON::->new->utf8->encode($r));

                }

                $INDENT--;

            }

        }

        # nested comments

        $num_errors += replies(

            language_code => $attrs{language_code}

          , topic_id => $t->{topic_id}

          , reply_to_post_number => $t->{post_number}

          , replies => $r->{comment_ids}

        ) if @{$r->{comment_ids}};

    }

    return $num_errors;

}

#######################################################################

# Initialisation

logmsg(NOTICE => "Starting $SCRIPT_FILENAME");

my $TAG_GROUP_LIBO_COMPONENT = "LibreOffice component";

# Categories

useragent_init();

{

    my $path = dirname($SCRIPT_FILENAME) . "/categories.json";

    open my $fh, "<", $path or panic("open($path): $!");

    my $categories = JSON::->new->utf8->decode( do { local $/ = undef; <$fh> } );

    close $fh or panic("close: $!");

    my %slugs;

    my $r = discourse_req("system", GET => "/categories.json");

    $slugs{$_->{slug}} = $_->{id} foreach @{$r->{category_list}->{categories}};

    foreach my $c (@$categories) {

        my $l = $c->{language_code} // panic();

        $CATEGORY_IDs{$l} = { slug => $c->{slug} };

        if (defined (my $id = $slugs{$c->{slug}})) {

            # the category already exists

            $CATEGORY_IDs{$l}->{id} = $id;

        } else {

            logmsg(NOTICE => "Creating category $c->{slug}");

            my $r = discourse_req("system", POST => "/categories.json", {

                name => $c->{name},

                slug => $c->{slug},

                custom_fields => { qa_enabled => JSON::true }

            });

            $CATEGORY_IDs{$l}->{id} = $r->{category}->{id} // panic();

        }

    }

    $r = discourse_req("system", POST => "/tag_groups.json", {

        tag_group => {

            name => $TAG_GROUP_LIBO_COMPONENT,

            tag_names => [ qw/common writer calc impress base draw math meta/ ],

            permissions => { everyone => 1 },

            one_per_topic => JSON::false

        }

    });

    panic("Couldn't create group tag") unless defined $r->{tag_group};

    # reorder (lexicographically) by slugs

    logmsg(NOTICE => "Updating and ordering categories");

    my (%categories_sorted, %positions);

    my @categories_sorted = sort { $a->{slug} cmp $b->{slug} } @$categories;

    foreach (my $i = 0; $i <= $#$categories; $i++) {

        $categories_sorted{$categories_sorted[$i]->{slug}} = $i;

    }

    my $offset = 0;

    $r = discourse_req("system", GET => "/categories.json");

    foreach my $c (@{$r->{category_list}->{categories}}) {

        my $s = $c->{slug} // panic();

        my %h;

        if ($s eq "uncategorized") {

            $h{color} = "3AB54A";

            $h{text_color} = "FFFFFF";

            $positions{$c->{id}} = 0;

        } elsif ($s eq "site-feedback") {

            $positions{$c->{id}} = scalar(@$categories) + 1;

        } elsif ($s eq "staff") {

            $positions{$c->{id}} = scalar(@$categories) + 2;

        } elsif ($s eq "lounge") {

            $positions{$c->{id}} = scalar(@$categories) + 3;

        } elsif (defined (my $i = $categories_sorted{$s})) {

            $positions{$c->{id}} = $i + 1;

            $h{num_featured_topics} = 1;

        } else {

            $positions{$c->{id}} = scalar(@$categories) + 4 + $offset;

            $offset++;

        }

        next unless %h;

        my $r = discourse_req("system", PUT => "/categories/$c->{id}.json", \%h);

        panic("Couldn't update category") unless defined $r->{success} and $r->{success} eq "OK";

    }

    $r = discourse_req("system", POST => "/categories/reorder",

        { mapping => JSON::->new->encode(\%positions) });

    panic("Couldn't reorder categories") unless defined $r->{success} and $r->{success} eq "OK";

}

# AskBot (and SSO linking information) user profiles

{

    my $path = dirname($SCRIPT_FILENAME) . "/users.json";

    logmsg(NOTICE => "Loading $path");

    open my $fh, "<", $path or panic("open($path): $!");

    my $profiles = JSON::->new->utf8->decode( do { local $/ = undef; <$fh> } );

    close $fh or panic("close: $!");

    # merge accounts with the same email address (into the account with lowest ID)

    my (%emails, %duplicates);

    foreach my $id (keys %$profiles) {

        my $p = $profiles->{$id} // panic();

        # `lc` is a bit YOLO but Discourse matches email addresses case-insensitively...

        my %e = ( lc($p->{email}) => 1 );

        $e{lc($_)} = 1 foreach @{$p->{sso_emails} // []};

        foreach (keys %e) {

            $emails{$_} //= [];

            push @{$emails{$_}}, $id;

        }

    }

    foreach my $e (keys %emails) {

        my $ids = $emails{$e} // panic();

        next unless $#$ids > 0;

        my ($id, @duplicates) = sort {$a <=> $b} @$ids;

        $duplicates{$id} = \@duplicates;

    }

    foreach my $id (sort {$a <=> $b} keys %duplicates) {

        my $dups = $duplicates{$id};

        my $username = $profiles->{$id}->{username} // panic();

        logmsg(INFO => "Merging user(s) ", join (", ", map {"#$_"} @$dups),

                            " with #$id ($username)");

        $ASKBOT_DUPLICATES{$_} = $id + 0 foreach @$dups;

    }

    my @reserved_usernames = # 'reserved_usernames' setting

        qw/admin moderator administrator mod sys system community info

           you name username user nickname discourse discourseorg

           discourseforum support/;

    my %usernames;

    my @profile_ids = sort {$a <=> $b} keys %$profiles;