ORB/modules/ORB.pm

## @file
# This file contains the implementation of the ORB block base class.
#
# @author  Chris Page <chris@starforge.co.uk>
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

## @class
#
package ORB;

use strict;
use experimental qw(smartmatch);
use v5.14;

use parent qw(Webperl::Block); # Features are just a specific form of Block
use Digest;
use CGI::Util qw(escape);
use HTML::Entities;
use Webperl::Utils qw(join_complex path_join hash_or_hashref);
use XML::Simple;
use DateTime;
use JSON;

# Hack the DateTime object to include the TO_JSON function needed to support
# JSON output of datetime objects. Outputs as ISO8601
sub DateTime::TO_JSON {
    my $dt = shift;

    return $dt -> format_cldr('yyyy-MM-ddTHH:mm:ssZZZZZ');
}

# ============================================================================
#  Constructor

## @cmethod $ new(%args)
# Overloaded constructor for ORB block modules. This will ensure that a valid
# item id has been stored in the block object data.
#
# @param args A hash of values to initialise the object with. See the Block docs
#             for more information.
# @return A reference to a new ORB object on success, undef on error.
sub new {
    my $invocant = shift;
    my $class    = ref($invocant) || $invocant;
    my $self     = $class -> SUPER::new(timefmt   => '%a, %d %b %Y %H:%M',
                                        entitymap => { '&ndash;'  => '-',
                                                       '&mdash;'  => '-',
                                                       '&rsquo;'  => "'",
                                                       '&lsquo;'  => "'",
                                                       '&ldquo;'  => '"',
                                                       '&rdquo;'  => '"',
                                                       '&hellip;' => '...',
                                                       '&gt;'     => '>',
                                                       '&lt;'     => '<',
                                                       '&amp;'    => '&',
                                                       '&nbsp;'   => ' ',
                                        },
                                        api_auth_header => 'Private-Token',
                                        api_auth_keylen => 24,
                                        @_)
        or return undef;

    # Formats of accepted types
    $self -> {"formats"} = {
        "recipename" => '^[-\w,. ]+$',
        "tags"       => '^[-\w ]+$',
        "quantity"   => '^[\d\w./]+$',
        "sepname"    => '^[-\w,.:()&;#*\ ]{1,255}$',
        "ingredient" => '^[-\w,.:()&;#*\ ]{1,255}$',
        "notes"      => '^[-()\w,."!\'\\/£$%;:@#?><* ]{1,255}$',
    };

    return $self;
}


# ============================================================================
#  HTML generation support

## @method void redirect($url)
# Redirect the user to the specified url.
#
# @param url The URL to send the user to.
sub redirect {
    my $self = shift;
    my $url  = shift;

    # There is ambiguity about whether 302/303 responses should contain cookies,
    # but all major browsers support doing this as of at least 2012 - see
    #  http://blog.dubbelboer.com/2012/11/25/302-cookie.html
    print $self -> {"cgi"} -> redirect( -url     => $url,
                                        -charset => 'utf-8',
                                        -cookie  => $self -> {"session"} -> session_cookies());

    # Prevent circular references from messing up shutdown
    $self -> {"template"} -> set_module_obj(undef) if($self -> {"template"});
    $self -> {"messages"} -> set_module_obj(undef) if($self -> {"messages"});
    $self -> {"system"} -> clear() if($self -> {"system"});
    $self -> {"appuser"} -> set_system(undef) if($self -> {"appuser"});

    $self -> {"dbh"} -> disconnect() if($self -> {"dbh"});
    $self -> {"logger"} -> end_log() if($self -> {"logger"});
    exit;
}


## @method $ generate_orb_page(%args)
# A convenience function to wrap page content in the standard page template. This
# function allows blocks to embed their content in a page without having to build
# the whole page including "common" items themselves. It should be called to wrap
# the content when the block's page_display is returning. Supported arguments are:
#
# - `title`:     The page title.
# - `content`:   The content to show in the page.
# - `leftmenu`:  Optional content to show in a left popup menu.
# - `extrahead`: Any extra directives to place in the header.
# - `extrajs`:   Any extra javascript to place in the footer.
# - `doclink`:   The name of a document link to include in the userbar. If not
#                supplied, no link is shown.
# @return A string containing the page.
sub generate_orb_page {
    my $self = shift;
    my $args = hash_or_hashref(@_);

    my $userbar = $self -> {"module"} -> load_module("ORB::Userbar");

    my ($topbar, $leftbar) = $userbar -> block_display($args -> {"title"}, $self -> {"block"}, $args -> {"doclink"});
    return $self -> {"template"} -> load_template("page.tem", {"%(extrahead)s" => $args -> {"extrahead"} // "",
                                                               "%(extrajs)s"   => $args -> {"extrajs"} // "",
                                                               "%(title)s"     => $args -> {"title"} // "",
                                                               "%(pagemenu)s"  => $self -> pagemenu($args -> {"active"}),
                                                               "%(leftmenu)s"  => $leftbar,
                                                               "%(userbar)s"   => $topbar,
                                                               "%(content)s"   => $args -> {"content"}});
}


## @method $ generate_errorbox(%args)
# Generate the HTML to show in the page when a fatal error has been encountered.
# The following options can be specified in the arguments:
#
# - `message`: The message to show in the page.
# - `title`:   The title to use for the error. If not set "{L_FATAL_ERROR}" is used.
#
# @param args A hash, or reference to a hash, of options.
# @return A string containing the page
sub generate_errorbox {
    my $self = shift;
    my $args = hash_or_hashref(@_);

    $self -> log("error:fatal", $args -> {"message"});

    return ($args -> {"title"} // "{L_FATAL_ERROR}",
            $self -> message_box(title   => $args -> {"title"} // "{L_FATAL_ERROR}",
                                 type    => "error",
                                 class   => "alert",
                                 summary => "{L_FATAL_ERROR_SUMMARY}",
                                 message => $args -> {"message"},
                                 buttons => [ { "message" => "{L_SITE_CONTINUE}",
                                                "colour"  => "standard",
                                                "href"    => "{V_[scriptpath]}"
                                              }
                                 ])
        );
}


## @method $ message_box(%args)
# Create a message box block to include in a page. This generates a templated
# message box to include in a page. It assumes the presence of messagebox.tem
# in the template directory, containing markers for a title, type, summary,
# long description and additional data. The type argument should correspond
# to an image in the {template}/images/messages/ directory without an extension.
# Supported arguments are:
#
#  - `title`:      The title of the message box.
#  - `type`:       The message type.
#  - `class`:      Optional additional classes to set on the box.
#  - `summary`:    A summary version of the message.
#  - `message`:    The full message body
#  - `additional`: Any additional content to include in the message box.
#  - `buttons`:    Optional reference to an array of hashes containing button
#                  data. Each hash in the array should contain three keys:
#                  - `colour`: specifies the button colour
#                  - `href`: the href to set in the button
#                  - `message`: the message to show in the button.
#
# @param args A hash, or reference to a hash, of arguments.
# @return A string containing the message box.
sub message_box {
    my $self = shift;
    my $args = hash_or_hashref(@_);

    my $buttonbar = "";

    # Has the caller specified any buttons?
    if($args -> {"buttons"}) {

        # Build the list of buttons...
        my $buttonlist = "";
        foreach my $button (@{$args -> {"buttons"}}) {
            $buttonlist .= $self -> {"template"} -> load_template("messagebox/button.tem",
                                                                  { "%(colour)s"  => $button -> {"colour"},
                                                                    "%(href)s"    => $button -> {"href"},
                                                                    "%(message)s" => $button -> {"message"}
                                                                  });
        }

        # Shove into the bar
        $buttonbar = $self -> {"template"} -> load_template("messagebox/buttonbar.tem",
                                                            { "%(buttons)s" => $buttonlist });
    }

    return $self -> {"template"} -> load_template("messagebox/box.tem",
                                                  { "%(title)s"      => $args -> {"title"},
                                                    "%(icon)s"       => $args -> {"type"} // "important",
                                                    "%(summary)s"    => $args -> {"summary"},
                                                    "%(message)s"    => $args -> {"message"},
                                                    "%(additional)s" => $args -> {"additional"},
                                                    "%(class)s"      => $args -> {"class"} // "secondary",
                                                    "%(buttons)s"    => $buttonbar,
                                                  });
}


## @method $ pagemenu($active)
# Create a page menu to include at the top of pages that need menu listing pages
#
# @param active The active page letter, and empty string or "all" for all, or
#               undef if none are active.
# @return A string containing the page menu
sub pagemenu {
    my $self   = shift;
    my $active = shift;

    return "" if(!defined($active));

    $active ||= "all";

    my $pages = "";
    foreach my $page ("0", "A" ... "Z", "All") {
        my $url = $self -> build_url(block    => "list",
                                     pathinfo => [ $page ]);

        $pages .= $self -> {"template"} -> load_template("navigation/pagemenu-page.tem",
                                                         { "%(active)s" => (lc($active) eq lc($page) ? "active" : ""),
                                                           "%(page)s"   => $page,
                                                           "%(url)s"    => $url });
    }

    return $self -> {"template"} -> load_template("navigation/pagemenu.tem",
                                                  { "%(pages)s" => $pages });
}


# ============================================================================
#  Permissions/Roles related.

## @method $ check_permission($action, $contextid, $userid)
# Determine whether the user has permission to peform the requested action. This
# should be overridden in subclasses to provide actual checks.
#
# @param action    The action the user is attempting to perform.
# @param contextid The ID of the metadata context the user is trying to perform
#                  an action in. If this is not given, the root context is used.
# @param userid    The ID of the user to check the permissions for. If not
#                  specified, the current session user is used.
# @return true if the user has permission, false if they do not, undef on error.
sub check_permission {
    my $self      = shift;
    my $action    = shift;
    my $contextid = shift || $self -> {"system"} -> {"roles"} -> {"root_context"};
    my $userid    = shift || $self -> {"session"} -> get_session_userid();

    return $self -> {"system"} -> {"roles"} -> user_has_capability($contextid, $userid, $action);
}


## @method $ check_login()
# Determine whether the current user is logged in, and if not force them to
# the login form.
#
# @return undef if the user is logged in and has access, otherwise a page to
#         send back with a permission error. If the user is not logged in, this
#         will 'silently' redirect the user to the login form.
sub check_login {
    my $self = shift;

    # Anonymous users need to get punted over to the login form
    if($self -> {"session"} -> anonymous_session()) {
        $self -> log("error:anonymous", "Redirecting anonymous user to login form");

        print $self -> {"cgi"} -> redirect($self -> build_login_url());
        exit;

    # Otherwise, permissions need to be checked
    } elsif(!$self -> check_permission("view")) {
        $self -> log("error:permission", "User does not have perission 'view'");

        # Logged in, but permission failed
        my $message = $self -> message_box(title   => "{L_PERMISSION_FAILED_TITLE}",
                                           type    => "error",
                                           class   => "alert",
                                           summary => "{L_PERMISSION_FAILED_SUMMARY}",
                                           message => "{L_PERMISSION_VIEW_DESC}",
                                           buttons => [ {"message" => $self -> {"template"} -> replace_langvar("SITE_CONTINUE"),
                                                         "colour"  => "blue",
                                                         "href"    => "{V_[scriptpath]}"} ]);

        return $self -> generate_orb_page(title => "{L_PERMISSION_FAILED_TITLE}",
                                          content => $message);
    }

    return undef;
}


# ============================================================================
#  API support

## @method $ is_api_operation()
# Determine whether the feature is being called in API mode, and if so what operation
# is being requested.
#
# @return A string containing the API operation name if the script is being invoked
#         in API mode, undef otherwise. Note that, if the script is invoked in API mode,
#         but no operation has been specified, this returns an empty string.
sub is_api_operation {
    my $self = shift;

    my @api = $self -> {"cgi"} -> multi_param('api');

    # No api means no API mode.
    return undef unless(scalar(@api));

    # API mode is set by placing 'api' in the first api entry. The second api
    # entry is the operation.
    return $api[1] || "" if($api[0] eq 'api');

    return undef;
}


## @method $ api_param($param, $hasval, $params)
# Determine whether an API parameter has been set, and optionally return
# its value. This checks through the list of API parameters specified and,
# if the named parameter is present, this will either return the value
# that follows it in the parameter list if $hasval is true, or it will
# simply return true to indicate the parameter is present.
#
# @param param  The name of the API parameter to search for.
# @param hasval If true, expect the value following the parameter in the
#               list of parameters to be the value thereof, and return it.
#               If false, this will return true if the parameter is present.
# @param params An optional reference to a list of parameters. If making
#               multiple calls to api_param, grabbing the api parameter
#               list beforehand and passing a reference to that into each
#               api_param call will help speed the process up a bit.
# @return The value for the parameter if it is set and hasval is true,
#         otherwise true if the paramter is present. If the parameter is
#         not present, this will return undef.
sub api_param {
    my $self   = shift;
    my $param  = shift;
    my $hasval = shift;
    my $params = shift;

    if(!$params) {
        my @api = $self -> {"cgi"} -> multi_param('api');
        return undef unless(scalar(@api));

        $params = \@api;
    }

    for(my $pos = 2; $pos < scalar(@{$params}); ++$pos) {
        if($params -> [$pos] eq $param) {
            return $hasval ? $params -> [$pos + 1] : 1;
        }
    }

    return undef;
}


## @method $ api_errorhash($code, $message)
# Generate a hash that can be passed to api_response() to indicate that an error was encountered.
#
# @param code    A 'code' to identify the error. Does not need to be numeric, but it
#                should be short, and as unique as possible to the error.
# @param message The human-readable error message.
# @return A reference to a hash to pass to api_response()
sub api_errorhash {
    my $self    = shift;
    my $code    = shift;
    my $message = shift;

    return { 'error' => {
                          'info' => $message,
                          'code' => $code
                        }
           };
}


## @method $ api_html_response($data)
# Generate a HTML response containing the specified data.
#
# @param data The data to send back to the client. If this is a hash, it is
#             assumed to be the result of a call to api_errorhash() and it is
#             converted to an appropriate error box. Otherwise, the data is
#             wrapped in a minimal html wrapper for return to the client.
# @return The html response to send back to the client.
sub api_html_response {
    my $self = shift;
    my $data = shift;

    # Fix up error hash returns
    $data = $self -> {"template"} -> load_template("api/html_error.tem", {"%(code)s" => $data -> {"error"} -> {"code"},
                                                                          "%(info)s" => $data -> {"error"} -> {"info"}})
        if(ref($data) eq "HASH" && $data -> {"error"});

    return $self -> {"template"} -> load_template("api/html_wrapper.tem", {"%(data)s" => $data});
}


## @method private $ _api_status($data)
# Based on the specified data hash, determine which HTTP status code
# to use in the response.
#
# @param data A reference to a hash containing the data that will be sent to
#             the client.
# @return A HTTP status string, including code and message.
sub _api_status {
    my $self = shift;
    my $data = shift;

    return "200 OK"
        unless(ref($data) eq "HASH" && $data -> {"error"} && $data -> {"error"} -> {"code"});

    given($data -> {"error"} -> {"code"}) {
        when("bad_request")      { return "400 Bad Request"; }
        when("not_found")        { return "404 Not Found"; }
        when("permission_error") { return "403 Forbidden"; }
        when("general_error")    { return "532 Lilliputian snotweasel foxtrot omegaforce"; }
        default { return "500 Internal Server Error"; }
    }
}


## @method private void _xml_api_response($data, %xmlopts)
# Print out the specified data as a XML response.
#
# @param data    The data to send back to the client as XML.
# @param xmlopts Additional options passed to XML::Simple::XMLout. See the
#                documentation for api_response() regarding this argument.
sub _xml_api_response {
    my $self    = shift;
    my $data    = shift;
    my %xmlopts = @_;
    my $xmldata;

    $xmlopts{"XMLDecl"} = '<?xml version="1.0" encoding="UTF-8" standalone="yes" ?>'
        unless(defined($xmlopts{"XMLDecl"}));

    $xmlopts{"KeepRoot"} = 0
        unless(defined($xmlopts{"KeepRoot"}));

    $xmlopts{"RootName"} = 'api'
        unless(defined($xmlopts{"RootName"}));

    eval { $xmldata = XMLout($data, %xmlopts); };
    $xmldata = $self -> {"template"} -> load_template("xml/error_response.tem", { "%(code)s"  => "encoding_failed",
                                                                                  "%(error)s" => "Error encoding XML response: $@"})
        if($@);

    my $status = $self -> _api_status($data);
    print $self -> {"cgi"} -> header(-type => 'application/xml',
                                     -status  => $status
                                     -charset => 'utf-8');
    if($ENV{MOD_PERL} && $status ne "200 OK") {
        $self -> {"cgi"} -> r -> rflush();
        $self -> {"cgi"} -> r -> status(200);
    }
    print Encode::encode_utf8($xmldata);
}


## @method private void _json_api_response($data)
# Print out the specified data as a JSON response.
#
# @param data The data to send back to the client as JSON.
sub _json_api_response {
    my $self = shift;
    my $data = shift;

    my $json = JSON -> new();
    my $status = $self -> _api_status($data);
    print $self -> {"cgi"} -> header(-type => 'application/json',
                                     -status  => $status,
                                     -charset => 'utf-8');
    if($ENV{MOD_PERL} && $status ne "200 OK") {
        $self -> {"cgi"} -> r -> rflush();
        $self -> {"cgi"} -> r -> status(200);
    }
    print Encode::encode_utf8($json -> pretty -> convert_blessed(1) -> encode($data));
}


## @method $ api_response($data, %xmlopts)
# Generate an API response containing the specified data. This function will not return
# if it is successful - it will return an response and exit. The content generated by
# this function will be either JSON or XML depending on whether the user has specified
# an appropriate 'format=' argument, whether a system default default is set, falling back
# on JSON otherwise.
#
# @param data    A reference to a hash containing the data to send back to the client as an
#                API response.
# @param xmlopts Options passed to XML::Simple::XMLout if the respons is in XML. Note that
#                the following defaults are set for you:
#                - XMLDecl is set to '<?xml version="1.0" encoding="UTF-8" standalone="yes" ?>'
#                - KeepRoot is set to 0
#                - RootName is set to 'api'
# @return Does not return if successful, otherwise returns undef.
sub api_response {
    my $self    = shift;
    my $data    = shift;
    my @xmlopts = @_;

    # What manner of result should be resulting?
    my $format = $self -> {"settings"} -> {"API:format"} || "json";
    $format = "json" if($self -> {"cgi"} -> param("format") && $self -> {"cgi"} -> param("format") =~ /^json$/i);
    $format = "xml"  if($self -> {"cgi"} -> param("format") && $self -> {"cgi"} -> param("format") =~ /^xml$/i);

    given($format) {
        when("xml") { $self -> _xml_api_response($data, @xmlopts); }
        default { $self -> _json_api_response($data); }
    }

    $self -> {"template"} -> set_module_obj(undef);
    $self -> {"messages"} -> set_module_obj(undef);
    $self -> {"system"} -> clear() if($self -> {"system"});
    $self -> {"session"} -> {"auth"} -> {"app"} -> set_system(undef) if($self -> {"session"} -> {"auth"} -> {"app"});

    $self -> {"dbh"} -> disconnect();
    $self -> {"logger"} -> end_log();

    exit;
}


## @method $ api_token_login()
# Determine whether the client has sent an API token as part of the http request, and
# if so establish whether the key is valid and corresponds to a user in the system.
# This will set up the global session object to be 'logged in' as the key owner,
# if they key is valid. Note that methods that rely on or generate session cookies
# are not going to operate correctly when this is used: use only for API code!
#
# @note If using token auth, https *must* be used, or you may as well remove the
# auth code entirely.
#
# @return The ID of the user the token corresponds to on success, undef if the user
#         has not provided a token header, or the token is not valid.
sub api_token_login {
    my $self = shift;

    $self -> clear_error();

    my $key = $self -> {"cgi"} -> http($self -> {"api_auth_header"});
    return undef unless($key);

    my ($checkkey) = $key =~ /^(\w+)$/;
    return undef unless($checkkey);

    my $sha256 = Digest -> new('SHA-256');
    $sha256 -> add($checkkey);
    my $crypt = $sha256 -> hexdigest();

    my $keyrec = $self -> {"dbh"} -> prepare("SELECT `user_id`
                                              FROM `".$self -> {"settings"} -> {"database"} -> {"apikeys"}."`
                                              WHERE `token` = ?
                                              AND `active` = 1
                                              ORDER BY `created` DESC
                                              LIMIT 1");
    $keyrec -> execute($crypt)
        or return $self -> self_error("Unable to look up api key: ".$self -> {"dbh"} -> errstr());

    my $keydata = $keyrec -> fetchrow_hashref()
        or return $self -> self_error("No matching api key record when looking for key '$checkkey'");

    # This is a bit of a hack, but as long as it is called before any other session
    # code in the API module, it'll fake a logged-in session.
    $self -> {"session"} -> {"sessuser"} = $keydata -> {"user_id"};

    return $keydata -> {"user_id"};
}


## @method $ api_token_generate($userid)
# Generate a guaranteed-unique API token/key for the specified user. This will record the
# new token in the database for later use, deactivating any previously-issued tokens for
# the user, and return a copy of the new token.
#
# @param userid The ID of the user to generate a token for
# @return The new token string on success, undef on error.
sub api_token_generate {
    my $self   = shift;
    my $userid = shift;
    my ($token, $crypt) = ('', '');

    $self -> clear_error();

    my $checkh = $self -> {"dbh"} -> prepare("SELECT `user_id`
                                              FROM `".$self -> {"settings"} -> {"database"} -> {"apikeys"}."`
                                              WHERE `token` = ?");

    # Generate tokens until we hit one that isn't already defined.
    do {
        $token = join("", map { ("a".."z", "A".."Z", 0..9)[rand 62] } 1..$self -> {"api_auth_keylen"});

        my $sha256 = Digest -> new('SHA-256');
        $sha256 -> add($token);
        $crypt = $sha256 -> hexdigest();

        $checkh -> execute($crypt)
            or return $self -> self_error("Unable to look up api token: ".$self -> {"dbh"} -> errstr());

    } while($checkh -> fetchrow_hashref());

    # Deactivate the user's old tokens
    my $blockh = $self -> {"dbh"} -> prepare("UPDATE `".$self -> {"settings"} -> {"database"} -> {"apikeys"}."`
                                              SET `active` = 0
                                              WHERE `active` = 1 AND `user_id` = ?");
    $blockh -> execute($userid)
        or return $self -> self_error("Unable to deactivate old api tokens: ".$self -> {"dbh"} -> errstr());

    # And add the new token
    my $newh = $self -> {"dbh"} -> prepare("INSERT INTO `".$self -> {"settings"} -> {"database"} -> {"apikeys"}."`
                                            (`user_id`, `token`, `created`)
                                            VALUES(?, ?, UNIX_TIMESTAMP())");

    my $row = $newh -> execute($userid, $crypt);
    return $self -> self_error("Unable to store token for user '$userid': ".$self -> {"dbh"} -> errstr) if(!$row);
    return $self -> self_error("Insert failed for token for user '$userid': no rows inserted") if($row eq "0E0");

    return $token;
}


# ============================================================================
#  General utility

## @method void log($type, $message)
# Log the current user's actions in the system. This is a convenience wrapper around the
# Logger::log function.
#
# @param type     The type of log entry to make, may be up to 64 characters long.
# @param message  The message to attach to the log entry, avoid messages over 128 characters.
sub log {
    my $self     = shift;
    my $type     = shift;
    my $message  = shift;

    $message = "[Item:".($self -> {"itemid"} ? $self -> {"itemid"} : "none")."] $message";
    $self -> {"logger"} -> log($type, $self -> {"session"} -> get_session_userid(), $self -> {"cgi"} -> remote_host(), $message);
}


## @method $ set_saved_state()
# Store the current status of the script, including block, api, pathinfo, and querystring
# to session variables for later restoration.
#
# @return true on success, undef on error.
sub set_saved_state {
    my $self = shift;

    $self -> clear_error();

    my $block = $self -> {"cgi"} -> param("block");
    my $res = $self -> {"session"} -> set_variable("saved_block", $block);
    return undef unless(defined($res));

    my @pathinfo = $self -> {"cgi"} -> multi_param("pathinfo");
    $res = $self -> {"session"} -> set_variable("saved_pathinfo", join("/", @pathinfo));
    return undef unless(defined($res));

    my @api = $self -> {"cgi"} -> multi_param("api");
    $res = $self -> {"session"} -> set_variable("saved_api", join("/", @api));
    return undef unless(defined($res));

    # Convert the query parameters to a string, skipping the block, pathinfo, and api
    my @names = $self -> {"cgi"} -> param;
    my @qstring = ();
    foreach my $name (@names) {
        next if($name eq "block" || $name eq "pathinfo" || $name eq "api");

        my @vals = $self -> {"cgi"} -> param($name);
        foreach my $val (@vals) {
            push(@qstring, escape($name)."=".escape($val));
        }
    }
    $res = $self -> {"session"} -> set_variable("saved_qstring", join("&amp;", @qstring));
    return undef unless(defined($res));

    return 1;
}


## @method @ get_saved_state()
# A convenience wrapper around Session::get_variable() for fetching the state saved in
# build_login_url().
#
# @return An array of strings, containing the block, pathinfo, api, and query string.
sub get_saved_state {
    my $self = shift;

    # Yes, these use set_variable. set_variable will return the value in the
    # variable, like get_variable, except that this will also delete the variable
    return ($self -> {"session"} -> set_variable("saved_block"),
            $self -> {"session"} -> set_variable("saved_pathinfo"),
            $self -> {"session"} -> set_variable("saved_api"),
            $self -> {"session"} -> set_variable("saved_qstring"));
}


## @method $ cleanup_entities($html)
# Wrangle the specified HTML into something that won't produce an unholy mess when
# passed to something that doesn't handle UTF-8 properly.
#
# @param html The HTML to process
# @return A somewhat cleaned-up string of HTML
sub cleanup_entities {
    my $self = shift;
    my $html = shift;

    $html =~ s/\r//g;
    return encode_entities($html, '^\n\x20-\x7e');
}


# ============================================================================
#  URL building

## @method $ build_login_url()
# Attempt to generate a URL that can be used to redirect the user to a login form.
# The user's current query state (course, block, etc) is stored in a session variable
# that can later be used to bring them back to the location this was called from.
#
# @return A relative login form redirection URL.
sub build_login_url {
    my $self = shift;

    # Store as much state as possible to restore after login (does not store POST
    # data!)
    $self -> set_saved_state();

    return $self -> build_url(block    => "login",
                              fullurl  => 1,
                              pathinfo => [],
                              params   => {},
                              forcessl => 1);
}


## @method $ build_return_url($fullurl)
# Pulls the data out of the session saved state, checks it for safety,
# and returns the URL the user should be redirected/linked to to return to the
# location they were attempting to access before login.
#
# @param fullurl If set to true, the generated url will contain the protocol and
#                host. Otherwise the URL will be absolute from the server root.
# @return A relative return URL.
sub build_return_url {
    my $self    = shift;
    my $fullurl = shift;
    my ($block, $pathinfo, $api, $qstring) = $self -> get_saved_state();

    # Return url block should never be "login"
    $block = $self -> {"settings"} -> {"config"} -> {"default_block"} if($block eq "login" || !$block);

    # Build the URL from them
    return $self -> build_url("block"    => $block,
                              "pathinfo" => $pathinfo,
                              "api"      => $api,
                              "params"   => $qstring,
                              "fullurl"  => $fullurl);
}


## @method $ build_url(%args)
# Build a url suitable for use at any point in the system. This takes the args
# and attempts to build a url from them. Supported arguments are:
#
# * fullurl  - if set, the resulting URL will include the protocol and host. Defaults to
#              false (URL is absolute from the host root).
# * block    - the name of the block to include in the url. If not set, the current block
#              is used if possible, otherwise the system-wide default block is used.
# * pathinfo - Either a string containing the pathinfo, or a reference to an array
#              containing pathinfo fragments. If not set, the current pathinfo is used.
# * api      - api fragments. If the first element is not "api", it is added.
# * params   - Either a string containing additional query string parameters to add to
#              the URL, or a reference to a hash of additional query string arguments.
#              Values in the hash may be references to arrays, in which case multiple
#              copies of the parameter are added to the query string, one for each
#              value in the array.
# * forcessl - If true, the URL is forced to https: rather than http:
# * anchor   - Optional anchor name to append to the URL after #
#
# @param args A hash of arguments to use when building the URL.
# @return A string containing the URL.
sub build_url {
    my $self = shift;
    my %args = @_;
    my $base = "";

    # Default the block, item, and API fragments if needed and possible
    $args{"block"} = ($self -> {"cgi"} -> param("block") || $self -> {"settings"} -> {"config"} -> {"default_block"})
        if(!defined($args{"block"}));

    if(!defined($args{"pathinfo"})) {
        my @cgipath = $self -> {"cgi"} -> multi_param("pathinfo");
        $args{"pathinfo"} = \@cgipath if(scalar(@cgipath));
    }

    if(!defined($args{"api"})) {
        my @cgiapi = $self -> {"cgi"} -> multi_param("api");
        $args{"api"} = \@cgiapi if(scalar(@cgiapi));
    }

    # Convert the pathinfo and api to slash-delimited strings
    my $pathinfo = join_complex($args{"pathinfo"}, joinstr => "/");
    my $api      = join_complex($args{"api"}, joinstr => "/");

    # Force the API call to start 'api' if it doesn't
    $api = "api/$api" if($api && $api !~ m|^/?api|);

    # build the query string parameters.
    my $querystring = join_complex($args{"params"}, joinstr => ($args{"joinstr"} || "&amp;"), pairstr => "=", escape => 1);

    # building the URL involves shoving the bits together. path_join is intelligent enough to ignore
    # anything that is undef or "" here, so explicit checks beforehand should not be needed.
    my $url = path_join($self -> {"settings"} -> {"config"} -> {"scriptpath"}, $args{"block"}, $pathinfo, $api);
    $url = path_join($self -> {"cgi"} -> url(-base => 1), $url)
        if($args{"fullurl"});

    # Strip block, pathinfo, and api from the query string if they've somehow made it in there.
    # Note this can't simply be made 'eg' as the progressive match can leave a trailing &
    if($querystring) {
        while($querystring =~ s{((?:&(?:amp;))?)(?:api|block|pathinfo)=[^&]+(&?)}{$1 && $2 ? "&" : ""}e) {}
        $url .= "?$querystring";
    }

    $url =~ s/^http:/https:/
        if($args{"forcessl"} && $url =~ /^http:/);

    $url .= "#".$args{"anchor"} if($args{"anchor"});

    return $url;
}


# ============================================================================
#  Documentation support

## @method $ get_documentation_url($doclink)
# Given a documentation link name, obtain the URL associated with that name.
#
# @param doclink The name of the documentation link to fetch.
# @return The documentation URL if the doclink is valid, undef otherwise.
sub get_documentation_url {
    my $self    = shift;
    my $doclink = shift;

    $self -> clear_error();

    # No point trying anything if there is no link name set.
    return undef if(!$doclink);

    my $urlh = $self -> {"dbh"} -> prepare("SELECT `url`
                                            FROM `".$self -> {"settings"} -> {"database"} -> {"docs"}."`
                                            WHERE `name` LIKE ?");
    $urlh -> execute($doclink)
        or return $self -> self_error("Unable to look up documentation link: ".$self -> {"dbh"} -> errstr);

    # Fetch the url row, and if one has been found return it.
    my $url = $urlh -> fetchrow_arrayref();
    return $url ? $url -> [0] : undef;
}

1;