#!/usr/bin/perl
#
# DW::Controller::Poll
#
# This controller is for the poll feature
#
# Authors:
#      Momiji <momijizukamori@gmail.com>
#
# Copyright (c) 2009-2024 by Dreamwidth Studios, LLC.
#
# This program is free software; you may redistribute it and/or modify it under
# the same terms as Perl itself. For a copy of the license, please reference
# 'perldoc perlartistic' or 'perldoc perlgpl'.
#

package DW::Controller::Poll;

use strict;
use warnings;

use DW::Controller;
use DW::Routing;
use DW::Template;
use DW::FormErrors;
use LJ::Poll;

DW::Routing->register_string( '/poll',  \&index_handler, app => 1, no_redirects => 1 );
DW::Routing->register_string( '/poll/', \&index_handler, app => 1, no_redirects => 1 );
DW::Routing->register_string( '/poll/create', \&create_handler, app => 1 );

sub index_handler {
    my ($opts) = @_;

    my ( $ok, $rv ) = controller( form_auth => 1 );
    return $rv unless $ok;

    my $r      = $rv->{r};
    my $form   = $r->did_post ? $r->post_args : $r->get_args;
    my $remote = $rv->{remote};

    # Flatten Hash::MultiValue into a regular hash, joining multiple values
    # with commas.  This is needed for checkbox poll questions, which submit
    # multiple values under the same "pollq-N" key.
    my %flat;
    foreach my $key ( keys %$form ) {
        $flat{$key} = join( ",", $form->get_all($key) );
    }

    unless ( LJ::text_in( \%flat ) ) {

        #    $body = "<?badinput?>";
        return;
    }

    my $pollid = ( $flat{'id'} || $flat{'pollid'} ) + 0;

    unless ($pollid) {
        return $r->redirect("$LJ::SITEROOT/poll/create");
    }

    my $poll = LJ::Poll->new($pollid);

    return error_ml('/poll/index.tt.pollnotfound') unless ( $poll && $poll->valid );

    my $u = $poll->journal;

    my $mode = "";
    $mode = $flat{'mode'}
        if ( defined $flat{'mode'} && $flat{'mode'} =~ /(enter|results|ans|clear)/ );

    # Handle opening and closing of polls
    # We do this first because a closed poll will alter how a poll is displayed
    if ( $poll->is_owner($remote) || $remote && $remote->can_manage($u) ) {
        if ( defined $flat{'mode'} && $flat{'mode'} =~ /(close|open)/ ) {
            $mode = $flat{'mode'};
            $poll->close_poll if ( $mode eq 'close' );
            $poll->open_poll  if ( $mode eq 'open' );
            $mode = 'results';
        }
    }

    # load the item being shown
    my $entry = $poll->entry;
    return error_ml('/poll/index.tt.error.postdeleted') unless ($entry);

    return error_ml('/poll/index.tt.error.cantview') unless ( $entry->visible_to($remote) );

    # bundle variables to be passed to the template
    my $vars = {
        remote    => $remote,
        u         => $u,
        poll      => $poll,
        pollid    => $pollid,
        poll_form => \%flat,
        mode      => $mode,
        entry     => $entry,
    };

    if ( defined $flat{'poll-submit'} && $r->did_post ) {
        my $error;
        my $error_code = LJ::Poll->process_submission( \%flat, \$error );
        if ($error) {
            $vars->{error}      = $error;
            $vars->{error_code} = $error_code;
        }
        else {
            return $r->redirect( $entry->url( style_opts => LJ::viewing_style_opts(%flat) ) );
        }
    }

    return DW::Template->render_template( 'poll/index.tt', $vars );
}

sub create_handler {
    my ($opts) = @_;

    my ( $ok, $rv ) = controller( form_auth => 1, authas => 1 );
    return $rv unless $ok;

    my $r        = $rv->{r};
    my $get      = $r->get_args;
    my $post     = $r->post_args;
    my $remote   = $rv->{remote};
    my $vars     = { remote => $remote };
    my $ml_scope = "/poll/create.tt";

    # some rules used for error checking
    my %RULES = (
        "elements" => {
            "max" => 255,    # maximum total number of elements allowed
        },
        "items" => {
            "min"       => 1,       # minimum number of options
            "start"     => 5,       # number of items shown at start
            "max"       => 255,     # max number of options
            "maxlength" => 1000,    # max length of an option's textual value, min is implicitly 0
            "more"      => 5,       # number of items to add when requesting more
        },
        "question" => {
            "maxlength" => 1000,    # maximum length of question allowed
        },
        "pollname" => {
            "maxlength" => 1000,    # maximum length of poll name allowed
        },
        "text" => {
            "size"      => 50,      # default size of a text element
            "maxlength" => 255,     # default maxlength of a text element
        },
        "size" => {
            "min" => 1,             # minimum allowed size value for a text element
            "max" => 100,           # maximum allowed size value for a text element
        },
        "maxlength" => {
            "min" => 1,             # minimum allowed maxlength value for a text element
            "max" => 255,           # maximum allowed maxlength value for a text element
        },
        "scale" => {
            "from"     => 1,        # default from value for a scale
            "to"       => 10,       # default to value for a scale
            "by"       => 1,        # default by value for a scale
            "maxitems" => 21,       # maximum number of items allowed in a scale
        },
        "checkbox" => {
            "checkmin" =>
                0,    # number of checkboxes a user must tick in that question (default 0: no limit)
            "checkmax" =>
                255,    # maximum number of checkboxes a user is allowed to tick in that question
        },
    );

    $vars->{rules} = \%RULES;
    my $remote_can_make_polls = $remote->can_create_polls;

    my $authas = $get->{'authas'} || $remote->{'user'};
    my $u;

    # If remote can make polls, make sure they can post to the authas journal
    # If remote can't make polls, make sure they maintain the authas journal
    if ($remote_can_make_polls) {
        my $authas_u = LJ::load_user($authas);
        $u = $authas_u if $authas_u and $remote->can_post_to($authas_u);
    }
    else {
        $u = LJ::get_authas_user($authas);
    }

    # Return error if previous check was unsuccessful
    return error_ml('error.invalidauth') unless ($u);

    # first pageview, show authas
    if ( !$r->did_post || $post->{'start_over'} ) {

        # postto switcher form
        # If remote can make polls, show all communities they have posting access to
        # If remote can't make polls, show only paid communities they maintain
        my $postto_html = "<form method='get' action='create'>\n";
        if ($remote_can_make_polls) {
            $postto_html .= LJ::make_authas_select(
                $remote,
                {
                    'authas'   => $get->{'authas'},
                    foundation => 1,
                    'label'    => LJ::Lang::ml('web.postto.label'),
                    'button'   => LJ::Lang::ml('web.postto.btn')
                }
            ) . "\n";
        }
        else {
            $postto_html .= LJ::make_authas_select(
                $remote,
                {
                    'authas'   => $get->{'authas'},
                    foundation => 1,
                    'label'    => LJ::Lang::ml('web.postto.label'),
                    'button'   => LJ::Lang::ml('web.postto.btn'),
                    'cap'      => 'makepoll',
                }
            ) . "\n";
        }
        $postto_html .= "</form>\n\n";
        $vars->{postto_html} = $postto_html;
    }

    # does the remote or selected user have the 'makepoll' cap?
    unless ( $remote_can_make_polls || $u->can_create_polls ) {

        # $body .= "<?h1 $ML{'Sorry'} h1?><?p $ML{'.error.accttype2'} p?>";
        # return;
    }

    # extra arguments for get requests
    my $getextra = $authas ne $remote->{'user'} ? "?authas=$authas" : '';
    $vars->{getextra} = $getextra;

    # variable to store what question the last action took place in
    my $focuson = "";

    #######################################################
    #
    # Function definitions
    #

    # builds a %poll object
    my $build_poll = sub {
        my $err = shift;

        # initialize the hash
        my $poll = {
            "name"    => "",
            "count"   => "0",
            "isanon"  => "no",
            "whoview" => "all",
            "whovote" => "all",
            "pq"      => [],
        };

        # make sure they don't plug in an outrageous count
        my $post_count = $post->{count} || 0;
        $post->{count} = 0 if $post_count < 0;
        $post->{count} = $RULES{elements}->{max}
            if $post_count > $RULES{elements}->{max};

        # form properties
        foreach my $it (qw(count name isanon whoview whovote)) {
            $poll->{$it} = $post->{$it} if $post->{$it};
        }

        # go through the count to build our hash
        foreach my $q ( 0 .. $poll->{'count'} - 1 ) {

            # sanify 'opts' form elements at this level
            # so we don't have to do it later
            my $opts = "pq_${q}_opts";
            $post->{$opts} = 0 if $post->{$opts} && $post->{$opts} < 0;
            $post->{$opts} = $RULES{'items'}->{'max'}
                if $post->{$opts} > $RULES{'items'}->{'max'};

            # question record
            my $qrec = {};

            # validate question attributes
            foreach my $atr (
                qw(type question opts size maxlength from to by checkmin checkmax lowlabel highlabel)
                )
            {
                my $val = $post->{"pq_${q}_$atr"};
                next
                    unless defined $val
                    || $atr eq 'question';    # 'question' is required, so always check it

                # ignore invalid types?
                next if $atr eq 'type' && $val !~ /^(radio|check|drop|text|scale)$/;

                # question too long/nonexistant
                if ( $atr eq 'question' ) {
                    if ( !$val ) {
                        $qrec->{$atr} = $val;
                        $err->{$q}->{$atr} = LJ::Lang::ml("$ml_scope.error.notext");
                    }
                    elsif ( length($val) > $RULES{$atr}->{'maxlength'} ) {
                        $qrec->{$atr} = substr( $val, 0, $RULES{$atr}->{'maxlength'} );
                    }
                    else {
                        $qrec->{$atr} = $val;
                    }

                    next;
                }

                # opts too long?
                if ( $atr eq 'opts' ) {
                    $qrec->{$atr} = int($val);
                    next;
                }

                # size too short/long?
                if ( $atr eq 'size' ) {
                    $qrec->{$atr} = int($val);

                    if (   $qrec->{$atr} > $RULES{$atr}->{'max'}
                        || $qrec->{$atr} < $RULES{$atr}->{'min'} )
                    {
                        $err->{$q}->{$atr} = LJ::Lang::ml( "$ml_scope.error.pqsizeinvalid2",
                            { 'min' => $RULES{$atr}->{'min'}, 'max' => $RULES{$atr}->{'max'} } );
                    }

                    next;
                }

                # maxlength too short/long?
                if ( $atr eq 'maxlength' ) {
                    $qrec->{$atr} = int($val);

                    if (   $qrec->{$atr} > $RULES{$atr}->{'max'}
                        || $qrec->{$atr} < $RULES{$atr}->{'min'} )
                    {
                        $err->{$q}->{$atr} = LJ::Lang::ml(
                            "$ml_scope.error.pqmaxlengthinvalid2",
                            {
                                'min' => $RULES{'maxlength'}->{'min'},
                                'max' => $RULES{'maxlength'}->{'max'}
                            }
                        );
                    }

                    next;
                }

                # from/to/by -- scale
                if ( $atr eq 'from' ) {
                    $qrec->{'to'}   = int( $post->{"pq_${q}_to"} )   || 0;
                    $qrec->{'from'} = int( $post->{"pq_${q}_from"} ) || 0;
                    $qrec->{'by'} =
                        int( $post->{"pq_${q}_by"} ) >= 1 ? int( $post->{"pq_${q}_by"} ) : 1;

                    if ( $qrec->{'by'} < $RULES{'by'}->{'min'} ) {
                        $err->{$q}->{'by'} = LJ::Lang::ml( "$ml_scope.error.scalemininvalid",
                            { 'min' => $RULES{'by'}->{'min'} } );
                    }

                    if ( $qrec->{'from'} >= $qrec->{'to'} ) {
                        $err->{$q}->{'from'} = LJ::Lang::ml("$ml_scope.error.scalemaxlessmin");
                    }

                    my $scaleoptions = ( ( $qrec->{to} - $qrec->{from} ) / $qrec->{by} ) + 1;
                    if ( $scaleoptions > $RULES{scale}->{maxitems} ) {
                        $err->{$q}->{to} = LJ::Lang::ml(
                            "$ml_scope.error.scaletoobig1",
                            {
                                'maxselections' => $RULES{scale}->{maxitems},
                                'selections'    => $scaleoptions - $RULES{scale}->{maxitems}
                            }
                        );
                    }

                    next;
                }

                if ( $atr eq 'checkmin' ) {
                    $qrec->{'checkmin'} = int( $post->{"pq_${q}_checkmin"} ) || 0;
                    $qrec->{'checkmax'} = int( $post->{"pq_${q}_checkmax"} ) || 255;
                    next;
                }

                # otherwise, let it by.
                $qrec->{$atr} = $val;
            }

            # insert record into poll structure
            $poll->{'pq'}->[$q] = $qrec;

            my $num_opts = 0;
            foreach my $o ( 0 .. $qrec->{'opts'} - 1 ) {
                next unless defined $post->{"pq_${q}_opt_$o"};

                if ( length( $post->{"pq_${q}_opt_$o"} ) > $RULES{'items'}->{'maxlength'} ) {
                    $qrec->{'opt'}->[$o] =
                        substr( $post->{"pq_${q}_opt_$o"}, 0, $RULES{'items'}->{'maxlength'} );
                    $err->{$q}->{$o}->{'items'} = LJ::Lang::ml("$ml_scope.error.texttoobig");
                    $num_opts++;
                }
                elsif ( length( $post->{"pq_${q}_opt_$o"} ) > 0 ) {

                    # no change necessary
                    $qrec->{'opt'}->[$o] = $post->{"pq_${q}_opt_$o"};
                    $num_opts++;
                }
            }

            # too few options specified?
            if ( $num_opts < $RULES{'items'}->{'min'} && $qrec->{'type'} =~ /^(drop|check|radio)$/ )
            {
                $err->{$q}->{'items'} = LJ::Lang::ml("$ml_scope.error.allitemsblank");
            }

            # checks if minimum and maximum options for checkboxes are OK

            if ( $qrec->{type} eq 'check' ) {
                my $checkmin = $qrec->{'checkmin'};
                if ( $checkmin > $num_opts ) {
                    $err->{$q}->{'checkmin'} = LJ::Lang::ml("$ml_scope.error.checkmintoohigh2");
                }

                my $checkmax = $qrec->{'checkmax'};
                if ( $checkmax < $checkmin ) {
                    $err->{$q}->{'checkmax'} = LJ::Lang::ml("$ml_scope.error.checkmaxtoolow2");
                }
            }
        }

        # closure to apply action to poll object, given 'type', 'item', and 'val'
        my $do_action = sub {
            my ( $type, $item, $val ) = @_;
            return unless $type && defined $item && defined $val;

            # move action
            if ( $type eq "move" ) {

                # up or down?
                my $adj = undef;
                if ( $val eq 'up' && $item - 1 >= 0 ) {
                    $adj = $item - 1;
                }
                elsif ( $val eq 'dn' && $item + 1 <= $poll->{'count'} ) {
                    $adj = $item + 1;
                }

                # invalid action
                return unless $adj;

                # swap poll items and error references
                my $swap = sub { return ( $_[1], $_[0] ) };

                ( $poll->{'pq'}->[$adj], $poll->{'pq'}->[$item] ) =
                    $swap->( $poll->{'pq'}->[$adj], $poll->{'pq'}->[$item] );

                ( $err->{$adj}, $err->{$item} ) =
                    $swap->( $err->{$adj}, $err->{$item} );

                # focus on the new position
                $focuson = $adj;

                return;
            }

            # delete action
            if ( $type eq "delete" ) {

                # delete from poll and decrement question count
                splice( @{ $poll->{"pq"} }, $item, 1 );
                $poll->{'count'}--;
                delete $err->{$item};

# focus on the previous item, unless this one was the top one, in which case we will focus on the new first
                $focuson = $item > 0 ? $item - 1 : 0;

                return;
            }

            # request more options
            if ( $type eq "request" ) {

                # add more items
                $poll->{"pq"}->[$item]->{'opts'} += $RULES{'items'}->{'more'};
                $poll->{'pq'}->[$item]->{'opts'} = $RULES{'items'}->{'max'}
                    if @{ $poll->{'pq'} }[$item]->{'opts'} > $RULES{'items'}->{'max'};

                # focus on the item we just added more options for
                $focuson = $item;

                return;
            }

            # insert
            if ( $type eq "insert" ) {

                # increase poll count
                $poll->{'count'}++;

                # splice new item in
                splice(
                    @{ $poll->{'pq'} },
                    $item, 0,
                    {
                        "question" => '',
                        "type"     => $val,
                        "opts"     => ( $val =~ /^(radio|drop|check)$/ )
                        ? $RULES{'items'}->{'start'}
                        : 0,
                        "opt" => [],
                    }
                );

                # focus on the new item
                $focuson = $item;

                return;
            }
        };

        # go through the count again, this time apply requested actions
        foreach my $q ( 0 .. $poll->{'count'} ) {

            # if there is an action, perform the action
            foreach my $act (qw(move delete insert request)) {

                # images stick an .x and .y on inputs
                my $do = $post->{"$act:$q:do.x"} ? "$act:$q:do.x" : "$act:$q:do";

                # catches everything but move
                if ( $post->{$do} ) {

                    # catches deletes, requests, etc
                    if ( $act ne 'insert' ) {
                        $do_action->( $act, $q, $act );
                        next;
                    }

                    # catches inserts
                    if ( $post->{"$act:$q"} =~ /^(radio|check|drop|text|scale)$/ ) {
                        $do_action->( $act, $q, $1 );
                        next;
                    }
                }

                # catches moves
                if ( defined $post->{"$act:$q:up.x"} && $post->{"$act:$q:up.x"} =~ /\d+/
                    || ( defined $post->{"$act:$q:dn.x"} && $post->{"$act:$q:dn.x"} =~ /\d+/ ) )
                {
                    $do_action->( $act, $q, $post->{"$act:$q:up.x"} ? 'up' : 'dn' );
                    next;
                }

            }
        }

        # all arguments are refs, nothing to return
        return $poll;
    };

    # variables to pass around
    my $poll = {};
    my $err  = {};

    # create poll code given a %poll object
    my $make_code = sub {
        my $poll = shift;

        my $ret;

        # start out the tag
        $ret .=
              "<poll name='"
            . LJ::ehtml( $poll->{'name'} )
            . "' isanon='"
            . $poll->{'isanon'}
            . "' whovote='"
            . LJ::ehtml( $poll->{'whovote'} )
            . "' whoview='"
            . LJ::ehtml( $poll->{'whoview'} ) . "'>\n";

        # go through and make <poll-question> tags
        foreach my $q ( 0 .. $poll->{'count'} - 1 ) {
            my $elem = $poll->{'pq'}->[$q];
            $ret .= "<poll-question type='$elem->{'type'}'";

            # fill in attributes
            if ( $elem->{'type'} eq 'text' ) {
                foreach my $el (qw(size maxlength)) {
                    $ret .= " $el='" . LJ::ehtml( $elem->{$el} ) . "'";
                }
            }
            elsif ( $elem->{'type'} eq 'scale' ) {
                foreach my $el (qw(from to by lowlabel highlabel)) {
                    $ret .= " $el='" . LJ::ehtml( $elem->{$el} ) . "'";
                }
            }
            elsif ( $elem->{'type'} eq 'check' ) {
                foreach my $el (qw(checkmin checkmax)) {
                    $ret .= " $el='" . LJ::ehtml( $elem->{$el} ) . "'";
                }
            }
            $ret .= ">\n";
            $ret .= $elem->{'question'} . "\n" if $elem->{'question'};

            if ( $elem->{'type'} =~ /^(radio|drop|check)$/ ) {

                # make <poll-item> tags
                foreach my $o ( 0 .. $elem->{'opts'} ) {
                    $ret .= "<poll-item>$elem->{'opt'}->[$o]</poll-item>\n"
                        if defined $elem->{'opt'}->[$o] && $elem->{'opt'}->[$o] ne '';
                }
            }
            $ret .= "</poll-question>\n";
        }

        # close off the poll
        $ret .= "</poll>";

        # escape html on this because it'll currently be sent to user so they can copy/paste
        return $ret;
    };

    # generates html for the hidden elements necessary to maintain
    # the state of the given poll
    my $poll_hidden = sub {
        my $poll = shift;

        my @elements = ();
        foreach my $k ( keys %$poll ) {

            # poll attributes
            unless ( ref $poll->{$k} eq 'ARRAY' ) {
                push @elements, ( $k, $poll->{$k} );
                next;
            }

            # poll questions
            my $q_idx = 0;
            foreach my $q ( @{ $poll->{$k} } ) {

                # question attributes
                foreach my $atr ( keys %$q ) {
                    unless ( ref $q->{$atr} eq 'ARRAY' ) {
                        push @elements, ( "${k}_${q_idx}_$atr", $q->{$atr} );
                        next;
                    }

                    # radio/text/drop options
                    my $opt_idx = 0;
                    foreach my $o ( @{ $q->{$atr} } ) {
                        push @elements, ( "${k}_${q_idx}_${atr}_$opt_idx", $o );
                        $opt_idx++;
                    }
                }

                $q_idx++;
            }
        }

        return \@elements;
    };

    # process post input
    if ( $r->did_post() && !$post->{'start_over'} ) {

        # load poll hash from $post and get action and error info
        $poll                = $build_poll->($err);
        $vars->{poll}        = $poll;
        $vars->{err}         = $err;
        $vars->{poll_hidden} = $poll_hidden;

        # generate poll preview for them
        if ( ( $post->{'see_preview'} || $post->{'see_code'} ) && !%$err ) {

            # generate code for preview
            my $code = $make_code->($poll);

            # parse code into a fake poll object so we can call "preview" on it
            my $err;
            my $codecopy = $code;    # parse function will eat the code
            my $pollobj = ( LJ::Poll->new_from_html( \$codecopy, \$err, {} ) )[0];

            return error_ml( "$ml_scope.error.parsing2", { 'err' => $err } ) if $err;

            my $update_url =
                LJ::BetaFeatures->user_in_beta( $remote => "updatepage" )
                ? "$LJ::SITEROOT/entry/new"
                : "$LJ::SITEROOT/update";
            my $usejournal = $getextra ? "?usejournal=$authas" : '';
            $vars->{update_url} = $update_url . $usejournal;
            $vars->{pollobj}    = $pollobj;
            $vars->{err}        = $err;
            $vars->{see_code}   = $post->{see_code} ? 1 : 0;
            $vars->{code}       = $code;
            return DW::Template->render_template( 'poll/preview.tt', $vars );
        }
    }

    return DW::Template->render_template( 'poll/create.tt', $vars );
}

1;