<commit_before>#!/usr/bin/env perl6
# Copyright © 2017
#     <NAME> <<EMAIL>>
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU Affero 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 Affero General Public License for more details.
#
# You should have received a copy of the GNU Affero General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

use Whateverable;
use Misc;

use IRC::Client;

unit class Squashable does Whateverable;

my $WIKI-PAGE-URL = ‘https://github.com/rakudo/rakudo/wiki/Monthly-Bug-Squash-Day’;
my $WIKI-PAGE-URL-RAW = ‘https://raw.githubusercontent.com/wiki/rakudo/rakudo/Monthly-Bug-Squash-Day.md’;
my $TIMEZONE-RANGE = (-12..14) × 60×60; # in seconds (let's be inclusive?)
my $CHANNEL = %*ENV<DEBUGGABLE> ?? ‘#whateverable’ !! ‘#perl6’;
my $PATH = ‘data/squashable’.IO;

my $next-event-lock = Lock.new;
my $next-event;
my $quiet-mode = False; # TODO is it safe or not?

method help($msg) {
    “Available commands: status, log, quiet, loud”
}

sub squashathon-range(Date $date) {
    (DateTime.new(:$date, timezone => $TIMEZONE-RANGE.max,
                  :00hour, :00minute, :00second).Instant)
    ..
    (DateTime.new(:$date, timezone => $TIMEZONE-RANGE.min,
                  :23hour, :59minute, :59second).Instant)
}

sub set-next-squashathon() {
    use HTTP::UserAgent;
    my $ua = HTTP::UserAgent.new;
    my $response = try { $ua.get: $WIKI-PAGE-URL-RAW };
    grumble ‘GitHub is down’ without $response;
    grumble ‘GitHub is down’ unless $response.is-success;
    if $response.content-type ne ‘text/plain; charset=utf-8’ {
        grumble ‘GitHub is weird’
    }
    my $page = $response.decoded-content;
    grumble ‘Can't parse the wiki page’ unless
    $page ~~ / ^^ ‘## Dates’                              \N*\n
               ^^ ‘|’ \s* ‘Date’ \s* ‘|’                  \N*\n
              [^^ ‘|-’                                    \N*\n]?
              [^^ ‘|’ \s* [‘[’|‘*’|‘~’]*
                   \s* $<dates>=[\d\d\d\d\-\d\d\-\d\d] >> \N*\n]+ /;
    my @dates = $<dates>.list.map: { Date.new: ~$_ };
    grumble ‘Can't parse the wiki page’ unless @dates;
    for @dates {
        if now < squashathon-range($_).max {
            $next-event-lock.protect: { $next-event = $_ }
            return
        }
    }
    grumble ‘The date for the next SQUASHathon is not set’
}

multi method irc-to-me($msg where /:i [ ‘quiet’ | ‘off’ | ‘shut up’ ] /) {
    $quiet-mode = True;
    ‘.oO( Mmmm… pizza! )’
}

multi method irc-to-me($msg where /:i [ ‘loud’ | ‘on’ ] /) {
    $quiet-mode = False;
    ‘ALRIGHT, LET'S DO IT!!!’
}

multi method irc-to-me($msg where /^ \s* [log|status|info|when|next]
                                     [ \s+ $<date>=[\d\d\d\d\-\d\d\-\d\d]]?
                                                                     \s* $/) {
    my $next;
    my $date = $<date>;
    with $date {
        try $next = Date.new: ~$_;
        CATCH { grumble ‘Invalid date format’ }
        grumble “I don't know about SQUASHathon on $_” if not $PATH.add(~$_).d;
    } else {
        set-next-squashathon;
        $next = $next-event-lock.protect: { $next-event }
    }
    sub utc-hour($secs) { ($secs ≥ 0 ?? ‘+’ !! ‘-’) ~ abs $secs ÷ 60 ÷ 60 }
    my $when = “($next UTC{utc-hour $TIMEZONE-RANGE.min}⌁”
                    ~ “UTC{utc-hour $TIMEZONE-RANGE.max})”;
    my $next-range = squashathon-range $next;
    if $msg !~~ /‘log’/ and not $date {
        if now < $next-range.min {
            my $warn = ($next-range.min - now)÷60÷60÷24 < 7 ?? ‘⚠🍕 ’ !! ‘’;
            $msg.reply: “{$warn}Next SQUASHathon {time-left $next-range.min} $when”
                            ~ “. See $WIKI-PAGE-URL”
        } else {
            $msg.reply: “🍕🍕 SQUASHathon is in progress!”
                         ~ “ The end of the event {time-left $next-range.max}”
                         ~ “. See $WIKI-PAGE-URL”
        }
    }
    my %files;
    %files<~log> = slurp $PATH.add(“$next/log”) if $PATH.add(“$next/log”).e;
    if $PATH.add(“$next/state”).e {
        my %state = from-json slurp $PATH.add(“$next/state”);
        for %state<stats>.pairs {
            if .value ~~ Associative {
                %files<stats> ~= “\n{.key}:\n”;
                my $prev;
                for .value.pairs.sort(*.key) {
                    %files<stats> ~= “├ $prev\n” with $prev;
                    LAST %files<stats> ~= “└ $prev\n”;
                    $prev = “{.key}: {.value}”
                }
            } else {
                %files<stats> ~= “\n{.key}: {.value}\n”;
            }
        }
        %files<stats> .= trim-leading;
    }
    return ‘Nothing there yet’ if $msg ~~ /‘log’/ and not %files;
    return unless %files;
    (‘’ but FileStore(%files)) but PrettyLink({“Log and stats: $_”})
}

use HTTP::Server::Async;
use JSON::Fast;

my %config = from-json slurp CONFIG;
my $server = HTTP::Server::Async.new: |(%config<squashable><host port>:p).Capture;
my $channel = Channel.new;

# TODO failures here will blow up (or get ignored) without proper handling
$server.handler: sub ($request, $response) {
    my $next = $next-event-lock.protect: { $next-event }
    without $next {
        $response.status = 500; $response.close;
        return
    }
    if now !~~ squashathon-range $next {
        $response.status = 200; $response.close;
        return
    }

    use Digest::SHA;
    use Digest::HMAC;
    my $body = $request.data;
    $body .= subbuf: 0..^($body - 1) if $body[*-1] == 0; # TODO trailing null byte. Why is it there?
    my $hmac = ‘sha1=’ ~ hmac-hex %config<squashable><secret>, $body, &sha1;
    if $hmac ne $request.headers<X-Hub-Signature> {
        $response.status = 400; $response.close(‘Signatures didn't match’);
        return
    }
    my $file = $request.headers<X-GitHub-Delivery>;
    mkdir $PATH.add(“$next”);
    spurt $PATH.add(“$next/$file”), $body if $file ~~ /^ [<.xdigit>|‘-’]+ $/;
    my $data = try from-json $body.decode;
    without $data {
        $response.status = 400; $response.close;
        return
    }
    $channel.send: $request.headers<X-GitHub-Event> => $data;
    $response.headers<Content-Type> = 'text/plain';
    $response.status = 200;
    $response.close
}

my $squashable = Squashable.new;
my %state;
try set-next-squashathon;
if $next-event.defined and $PATH.add(“$next-event/state”).e {<commit_msg>Process ping payload to test webhooks<commit_after>#!/usr/bin/env perl6
# Copyright © 2017
#     <NAME> <<EMAIL>>
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU Affero 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 Affero General Public License for more details.
#
# You should have received a copy of the GNU Affero General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

use Whateverable;
use Misc;

use IRC::Client;

unit class Squashable does Whateverable;

my $WIKI-PAGE-URL = ‘https://github.com/rakudo/rakudo/wiki/Monthly-Bug-Squash-Day’;
my $WIKI-PAGE-URL-RAW = ‘https://raw.githubusercontent.com/wiki/rakudo/rakudo/Monthly-Bug-Squash-Day.md’;
my $TIMEZONE-RANGE = (-12..14) × 60×60; # in seconds (let's be inclusive?)
my $CHANNEL = %*ENV<DEBUGGABLE> ?? ‘#whateverable’ !! ‘#perl6’;
my $PATH = ‘data/squashable’.IO;

my $next-event-lock = Lock.new;
my $next-event;
my $quiet-mode = False; # TODO is it safe or not?

method help($msg) {
    “Available commands: status, log, quiet, loud”
}

sub squashathon-range(Date $date) {
    (DateTime.new(:$date, timezone => $TIMEZONE-RANGE.max,
                  :00hour, :00minute, :00second).Instant)
    ..
    (DateTime.new(:$date, timezone => $TIMEZONE-RANGE.min,
                  :23hour, :59minute, :59second).Instant)
}

sub set-next-squashathon() {
    use HTTP::UserAgent;
    my $ua = HTTP::UserAgent.new;
    my $response = try { $ua.get: $WIKI-PAGE-URL-RAW };
    grumble ‘GitHub is down’ without $response;
    grumble ‘GitHub is down’ unless $response.is-success;
    if $response.content-type ne ‘text/plain; charset=utf-8’ {
        grumble ‘GitHub is weird’
    }
    my $page = $response.decoded-content;
    grumble ‘Can't parse the wiki page’ unless
    $page ~~ / ^^ ‘## Dates’                              \N*\n
               ^^ ‘|’ \s* ‘Date’ \s* ‘|’                  \N*\n
              [^^ ‘|-’                                    \N*\n]?
              [^^ ‘|’ \s* [‘[’|‘*’|‘~’]*
                   \s* $<dates>=[\d\d\d\d\-\d\d\-\d\d] >> \N*\n]+ /;
    my @dates = $<dates>.list.map: { Date.new: ~$_ };
    grumble ‘Can't parse the wiki page’ unless @dates;
    for @dates {
        if now < squashathon-range($_).max {
            $next-event-lock.protect: { $next-event = $_ }
            return
        }
    }
    grumble ‘The date for the next SQUASHathon is not set’
}

multi method irc-to-me($msg where /:i [ ‘quiet’ | ‘off’ | ‘shut up’ ] /) {
    $quiet-mode = True;
    ‘.oO( Mmmm… pizza! )’
}

multi method irc-to-me($msg where /:i [ ‘loud’ | ‘on’ ] /) {
    $quiet-mode = False;
    ‘ALRIGHT, LET'S DO IT!!!’
}

multi method irc-to-me($msg where /^ \s* [log|status|info|when|next]
                                     [ \s+ $<date>=[\d\d\d\d\-\d\d\-\d\d]]?
                                                                     \s* $/) {
    my $next;
    my $date = $<date>;
    with $date {
        try $next = Date.new: ~$_;
        CATCH { grumble ‘Invalid date format’ }
        grumble “I don't know about SQUASHathon on $_” if not $PATH.add(~$_).d;
    } else {
        set-next-squashathon;
        $next = $next-event-lock.protect: { $next-event }
    }
    sub utc-hour($secs) { ($secs ≥ 0 ?? ‘+’ !! ‘-’) ~ abs $secs ÷ 60 ÷ 60 }
    my $when = “($next UTC{utc-hour $TIMEZONE-RANGE.min}⌁”
                    ~ “UTC{utc-hour $TIMEZONE-RANGE.max})”;
    my $next-range = squashathon-range $next;
    if $msg !~~ /‘log’/ and not $date {
        if now < $next-range.min {
            my $warn = ($next-range.min - now)÷60÷60÷24 < 7 ?? ‘⚠🍕 ’ !! ‘’;
            $msg.reply: “{$warn}Next SQUASHathon {time-left $next-range.min} $when”
                            ~ “. See $WIKI-PAGE-URL”
        } else {
            $msg.reply: “🍕🍕 SQUASHathon is in progress!”
                         ~ “ The end of the event {time-left $next-range.max}”
                         ~ “. See $WIKI-PAGE-URL”
        }
    }
    my %files;
    %files<~log> = slurp $PATH.add(“$next/log”) if $PATH.add(“$next/log”).e;
    if $PATH.add(“$next/state”).e {
        my %state = from-json slurp $PATH.add(“$next/state”);
        for %state<stats>.pairs {
            if .value ~~ Associative {
                %files<stats> ~= “\n{.key}:\n”;
                my $prev;
                for .value.pairs.sort(*.key) {
                    %files<stats> ~= “├ $prev\n” with $prev;
                    LAST %files<stats> ~= “└ $prev\n”;
                    $prev = “{.key}: {.value}”
                }
            } else {
                %files<stats> ~= “\n{.key}: {.value}\n”;
            }
        }
        %files<stats> .= trim-leading;
    }
    return ‘Nothing there yet’ if $msg ~~ /‘log’/ and not %files;
    return unless %files;
    (‘’ but FileStore(%files)) but PrettyLink({“Log and stats: $_”})
}

use HTTP::Server::Async;
use JSON::Fast;

my %config = from-json slurp CONFIG;
my $server = HTTP::Server::Async.new: |(%config<squashable><host port>:p).Capture;
my $channel = Channel.new;
my $squashable = Squashable.new;

# TODO failures here will blow up (or get ignored) without proper handling
$server.handler: sub ($request, $response) {
    my $next = $next-event-lock.protect: { $next-event }
    without $next {
        $response.status = 500; $response.close;
        return
    }
    use Digest::SHA;
    use Digest::HMAC;
    my $body = $request.data;
    $body .= subbuf: 0..^($body - 1) if $body[*-1] == 0; # TODO trailing null byte. Why is it there?
    my $hmac = ‘sha1=’ ~ hmac-hex %config<squashable><secret>, $body, &sha1;
    if $hmac ne $request.headers<X-Hub-Signature> {
        $response.status = 400; $response.close(‘Signatures didn't match’);
        return
    }
    my $data = try from-json $body.decode;
    without $data {
        $response.status = 400; $response.close(‘Invalid JSON’);
        return
    }
    if $data<zen>:exists {
        my $text = “Webhook for {$data<repository><full_name>} is now ”
                 ~ ($data<hook><active>??‘active’!!‘inactive’) ~ ‘! ’
                 ~ $data<zen>;
        $squashable.irc.send: :$text, where => $CHANNEL; # TODO race?
    }
    if now !~~ squashathon-range $next {
        $response.status = 200; $response.close;
        return
    }
    my $file = $request.headers<X-GitHub-Delivery>;
    mkdir $PATH.add(“$next”);
    spurt $PATH.add(“$next/$file”), $body if $file ~~ /^ [<.xdigit>|‘-’]+ $/;

    $channel.send: $request.headers<X-GitHub-Event> => $data;
    $response.headers<Content-Type> = 'text/plain';
    $response.status = 200;
    $response.close
}

my %state;
try set-next-squashathon;
if $next-event.defined and $PATH.add(“$next-event/state”).e {
{'fraction_non_alphanumeric': 0.17086855144272806, 'fraction_numerical': 0.008889536578257067, 'mean_word_length': 2.152997932460372, 'pattern_counts': {'":': 0, '<': 65, '<?xml version=': 0, '>': 70, 'https://': 4, 'lorem ipsum': 0, 'www.': 2, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 14, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4179820', 'n_tokens_mistral': 4981, 'n_tokens_neox': 4752, 'n_words': 1195}