Skip to content

Instantly share code, notes, and snippets.

@Whateverable
Created June 2, 2018 20:06
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save Whateverable/2f4d3141f8316a201904bcd597a8c207 to your computer and use it in GitHub Desktop.
squashable6
Type check failed in binding to parameter ''; expected Any but got Mu (Mu)
  in method irc-to-me at /home/bisectable/git/whateverable/lib/Whateverable.pm6 line 187 (⚠ uncommitted)
  in sub  at /home/bisectable/git/whateverable/lib/Whateverable.pm6 line 70 (⚠ uncommitted)
  in block  at /home/bisectable/.rakudobrew/moar-master/install/share/perl6/site/sources/67654E203267F9CE57E3CC46CF4B19FB7CAB95A3 (IRC::Client) line 290
  in method handle-event at /home/bisectable/.rakudobrew/moar-master/install/share/perl6/site/sources/67654E203267F9CE57E3CC46CF4B19FB7CAB95A3 (IRC::Client) line 228
  in block  at /home/bisectable/.rakudobrew/moar-master/install/share/perl6/site/sources/67654E203267F9CE57E3CC46CF4B19FB7CAB95A3 (IRC::Client) line 109
  in block  at /home/bisectable/.rakudobrew/moar-master/install/share/perl6/site/sources/67654E203267F9CE57E3CC46CF4B19FB7CAB95A3 (IRC::Client) line 104
# Copyright © 2016-2017
# Aleks-Daniel Jakimenko-Aleksejev <alex.jakimenko@gmail.com>
# Copyright © 2016
# Daniel Green <ddgreen@gmail.com>
#
# 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 File::Directory::Tree;
use File::Temp;
use HTTP::UserAgent;
use IRC::Client::Message;
use IRC::Client;
use IRC::TextColor;
use JSON::Fast;
use Number::Denominate;
use Pastebin::Gist;
use Terminal::ANSIColor;
use Text::Diff::Sift4;
use Misc;
our $RAKUDO = (%*ENV<TESTABLE> // ).contains(rakudo-mock)
?? ./t/data/rakudo.IO.absolute
!! ./data/rakudo-moar.IO.absolute;
constant MOARVM = ./data/moarvm.IO.absolute;
constant SOURCE = https://github.com/perl6/whateverable;
constant WIKI = https://github.com/perl6/whateverable/wiki/;
constant WORKING-DIRECTORY = ..IO.absolute; # TODO not supported yet
constant ARCHIVES-LOCATION = {WORKING-DIRECTORY}/data/builds.IO.absolute;
constant BUILDS-LOCATION = /tmp/whateverable/.IO.absolute;
constant MESSAGE-LIMIT is export = 260;
constant COMMITS-LIMIT = 500;
our $GIST-LIMIT = 10_000;
constant $CAVE = #whateverable;
constant $PARENTS = AlexDaniel, MasterDuke;
our $RAKUDO-REPO = https://github.com/rakudo/rakudo;
our $CONFIG;
sub ensure-config is export { $CONFIG //= from-json slurp; }
constant Message = IRC::Client::Message;
unit role Whateverable[:$default-timeout = 10] does IRC::Client::Plugin does Helpful;
my $default-stdin = slurp stdin;
my role Enough { } # to prevent recursion in exception handling
method TWEAK {
# wrap around everything to catch exceptions
once { # per class
self.^lookup(irc-to-me).wrap: sub ($self, $msg) {
return if $msg.channel ne $CAVE and $msg.args[1].starts-with: what:;
# ↑ ideally this check shouldn't be here, but it's much harder otherwise
LEAVE sleep 0.02; # https://github.com/perl6/whateverable/issues/163
try {
my $result = callsame;
return without $result;
return $result but Reply($msg) if $result !~~ Promise;
return start sub {
try return (await $result) but Reply($msg);
$self.handle-exception: $!, $msg
}()
}
$self.handle-exception: $!, $msg
};
self.^lookup(filter).wrap: sub ($self, $response) {
my &filter = nextcallee;
try { return filter $self, $response }
return Ow! Where's a camcorder when ya need one? if $response ~~ Enough;
try { return filter $self, $self.handle-exception($!, $response.?msg) }
Sorry kid, that's not my department.
};
}
# TODO roles should not have TWEAK method
}
method handle-exception($exception, $msg?) is export {
CATCH { # exception handling is too fat, so let's do this also…
.note;
return Exception was thrown while I was trying to handle another exception…
~ What are they gonna do to me, Sarge? What are they gonna do⁈
}
if $exception ~~ Whateverable::X::HandleableAdHoc { # oh, it's OK!
return $exception.message but Reply($_) with $msg;
return $exception.message
}
note $exception;
given $msg {
# TODO handle other types
when IRC::Client::Message::Privmsg::Channel {
if .channel ne $CAVE {
.irc.send-cmd: PRIVMSG, $CAVE, I'm acting stupid on {.channel}. Help me.,
:server(.server), :prefix($PARENTS.join(, ) ~ : )
}
}
default {
.irc.send-cmd: PRIVMSG, $CAVE, Unhandled exception somewhere!,
:server(.server), :prefix($PARENTS.join(, ) ~ : );
}
}
my ($text, @files) = flat self.awesomify-exception: $exception;
@files .= map({ uncommitted- ~ .split(/).tail => .IO.slurp });
@files.push: |git-diff-HEAD.patch => run(:out, git, diff, HEAD).out.slurp-rest if @files;
@files.push: result.md => $text;
my $return = ( but FileStore(%@files))
but PrettyLink({No! It wasn't me! It was the one-armed man! Backtrace: $_});
# https://youtu.be/MC6bzR9qmxM?t=97
$return = $return but Reply($_) with $msg;
if $msg !~~ IRC::Client::Message::Privmsg::Channel {
$msg.irc.send-cmd: PRIVMSG, $CAVE, $return but Enough,
:server($msg.server), :prefix($PARENTS.join(, ) ~ : );
return
}
$return
}
method awesomify-exception($exception) {
my @local-files;
my $sha = run(:out, git, rev-parse, --verify, HEAD).out.slurp-rest;
<pre> ~
$exception.gist.lines.map({
# TODO Proper way to get data out of exceptions?
# For example, right now it is broken for paths with spaces
when /:s ^([\s**2|\s**6]in \w+ \S* at “{WORKING-DIRECTORY}/?)$<path>=[\S+](
[<.ws>‘(’<-[)]>+‘)’]? line )$<line>=[\d+]$/ {
my $status = run :out, git, status, --porcelain, --untracked-files=no,
--, ~$<path>;
proceed if !$status && !%*ENV<DEBUGGABLE>; # not a repo file and not in the debug mode
my $private-debugging = !$status;
$status = $status.out.slurp-rest;
my $uncommitted = $status && !$status.starts-with: ; # not committed yet
@local-files.push: ~$<path> if $uncommitted || $private-debugging;
my $href = $uncommitted || $private-debugging
?? #file-uncommitted-{$<path>.split(/).tail.lc.trans(. => -)}- # TODO not perfect but good enough
!! {SOURCE}/blob/$sha/{markdown-escape $<path>}#;
$href ~= L$<line>;
markdown-escape($0) ~
# let's hope for the best ↓
<a href="$href">{$<path>}</a> ~
markdown-escape($1 ~ $<line>) ~
($uncommitted ?? (⚠ uncommitted) !! )
}
default { $_ }
}).join(“\n)
~ </pre>, @local-files
}
multi method irc-to-me(Message $msg where .text ~~
#↓ Matches only one space on purpose (for whitespace-only stdin)
/:i^ [stdin] [‘ ’|‘=’] [clear|delete|reset|unset] $/) {
$default-stdin = slurp stdin;
STDIN is reset to the default value
}
multi method irc-to-me(Message $msg where .text ~~ /:i^ [stdin] [‘ ’|‘=’] $<stdin>=.* $/) {
my $file = self.process-code: ~$<stdin>, $msg;
$default-stdin = $file.slurp;
unlink $file;
STDIN is set to «{shorten $default-stdin, 200}» # TODO is 200 a good limit
}
multi method irc-to-me(Message $ where .text ~~ /:i^ [source|url] ‘?’? \s* $/ --> SOURCE) {}
multi method irc-to-me(Message $ where .text ~~ /:i^ wiki ‘?’? \s* $/) { self.get-wiki-link }
multi method irc-to-me(Message $msg where .text ~~ /:i^ [help|usage] ‘?’? \s* $/) {
self.help($msg) ~ # See wiki for more examples: {self.get-wiki-link}
}
multi method irc-to-me(Message $msg where .text ~~ /:i^ uptime \s* $/) {
use nqp;
use Telemetry;
(denominate now - $*INIT-INSTANT) ~ ,
~ T<max-rss>.fmt(%.2f) ÷ 1024 ~ MiB maxrss.
~ (with nqp::getcomp("perl6") {
This is {.implementation} version {.config<version>}
~ built on {.backend.version_string}
~ implementing {.language_name} {.language_version}.
})
}
multi method irc-notice-me( $ --> Nil) {} # Issue #321
multi method irc-privmsg-me($ --> Sorry, it is too private here) {} # TODO issue #16
multi method irc-to-me($) {
I cannot recognize this command. See wiki for some examples: ~ self.get-wiki-link
}
sub I'm-alive is export {
return if %*ENV<TESTABLE> or %*ENV<DEBUGGABLE>;
use NativeCall;
sub sd_notify(int32, str --> int32) is native(systemd) {*};
sd_notify 0, WATCHDOG=1; # this may be called too often, see TODO below
}
multi method irc-all($) {
# TODO https://github.com/zoffixznet/perl6-IRC-Client/issues/50
I'm-alive;
$.NEXT
}
method get-wiki-link { WIKI ~ self.^name }
method get-short-commit($original-commit) { # TODO not an actual solution tbh
$original-commit ~~ /^ <xdigit> ** 7..40 $/
?? $original-commit.substr(0, 7)
!! $original-commit
}
# TODO $default-timeout is VNNull when working in non-OOP style. Rakudobug it?
sub get-output(*@run-args, :$timeout = $default-timeout || 10,
:$stdin, :$ENV, :$cwd = $*CWD, :$chomp = True) is export {
my $proc = Proc::Async.new: |@run-args;
my $fh-stdin;
LEAVE .close with $fh-stdin;
my $temp-file;
LEAVE unlink $_ with $temp-file;
with $stdin {
if $stdin ~~ IO::Path {
$fh-stdin = $stdin.open
} elsif $stdin ~~ IO::Handle {
$fh-stdin = $stdin
} else {
$temp-file = write-code $stdin;
$fh-stdin = $temp-file.IO.open
}
$proc.bind-stdin: $fh-stdin
}
my @chunks;
my $result;
my $s-start = now;
my $s-end;
react {
whenever $proc.stdout { @chunks.push: $_ }; # RT #131763
whenever $proc.stderr { @chunks.push: $_ };
whenever Promise.in($timeout) {
$proc.kill; # TODO sends HUP, but should kill the process tree instead
@chunks.push: «timed out after $timeout seconds»
}
whenever $proc.start: :$ENV, :$cwd { #: scheduler => BEGIN ThreadPoolScheduler.new { # TODO do we need to set scheduler?
$result = $_;
$s-end = now;
done
}
}
my $output = @chunks.join;
%(
output => $chomp ?? $output.chomp !! $output,
exit-code => $result.exitcode,
signal => $result.signal,
time => $s-end - $s-start,
)
}
sub perl6-grep($stdin, $regex is copy, :$timeout = 180, :$complex = False, :$hack = 0) is export {
my $full-commit = to-full-commit HEAD ~ (^ x $hack);
die No build for $full-commit. Oops! unless build-exists $full-commit;
$regex = m⦑ $regex;
# TODO can we do something smarter?
my $sep = $complex ?? “\0\0” !! “\0”;
my $magic = INIT \$*ARGFILES.nl-in = $sep; INIT \$*OUT.nl-out = $sep;
~ use nqp;
~ next unless
~ ($complex ?? nqp::substr($_, 0, nqp::index($_, “\0”)) ~~ !! ) ~ \n
~ $regex ~ ;\n
~ last if $++ > ~ $GIST-LIMIT;
my $file = write-code $magic;
LEAVE unlink $_ with $file;
my $result = run-snippet $full-commit, $file, :$timeout, :$stdin, args => (-np,);
my $output = $result<output>;
# numbers less than zero indicate other weird failures ↓
grumble Something went wrong ($output) if $result<signal> < 0;
$output ~= «exit code = $result<exit-code>» if $result<exit-code> ≠ 0;
$output ~= «exit signal = {Signal($result<signal>)} ($result<signal>)» if $result<signal> ≠ 0;
grumble $output if $result<exit-code> ≠ 0 or $result<signal> ≠ 0;
my @elems = $output.split: ($complex ?? \0\0 !! \0), :skip-empty;
if @elems > $GIST-LIMIT {
grumble Cowardly refusing to gist more than $GIST-LIMIT lines
}
@elems
}
sub fetch-build($full-commit-hash, :$backend!) {
my $done;
if %*ENV<TESTABLE> { # keep asking for more time
$done = Promise.new;
start react {
whenever $done { done }
whenever Supply.interval: 0.5 { test-delay }
}
}
LEAVE { $done.keep } if $done.defined && %*ENV<TESTABLE>;
my $ua = HTTP::UserAgent.new;
$ua.timeout = 10;
my $arch = $*KERNEL.name ~ - ~ $*KERNEL.hardware;
my $link = {$CONFIG<mothership>}/$full-commit-hash?type=$backend&arch=$arch;
note Attempting to fetch $full-commit-hash;
my $response = $ua.get: :bin, $link;
return unless $response.is-success;
my $disposition = $response.header.field(Content-Disposition).values[0];
return unless $disposition ~~ /‘filename=’\s*(<.xdigit>+[‘.zst’|‘.lrz’])/;
my $location = ARCHIVES-LOCATION.IO.add: $backend;
my $archive = $location.add: ~$0;
spurt $archive, $response.content, :bin;
if $archive.ends-with: .lrz { # populate symlinks
my $proc = run :out, :bin, <lrzip -dqo - -->, $archive;
my $list = run :in($proc.out), :out, <tar --list --absolute-names>;
my @builds = gather for $list.out.lines { # TODO assumes paths without newlines, dumb but I don't see another way
take ~$0 if /^/tmp/whateverable/$backend/’(<.xdigit>+)//;
}
for @builds.unique {
my $symlink = $location.add: $_;
$symlink.unlink if $symlink.e; # remove existing (just in case)
$archive.IO.symlink: $symlink;
}
}
return $archive
}
sub build-exists($full-commit-hash,
:$backend=rakudo-moar,
:$force-local=False) is export {
my $archive = {ARCHIVES-LOCATION}/$backend/$full-commit-hash.zst.IO;
my $archive-lts = {ARCHIVES-LOCATION}/$backend/$full-commit-hash.IO;
# ↑ long-term storage (symlink to a large archive)
my $answer = ($archive, $archive-lts).any.e.so;
if !$force-local && !$answer && $CONFIG<mothership> {
return so fetch-build $full-commit-hash, :$backend
}
$answer
}
method get-similar($tag-or-hash, @other?, :$repo=$RAKUDO) {
my @options = @other;
my @tags = get-output(cwd => $repo, git, tag,
--format=%(*objectname)/%(objectname)/%(refname:strip=2),
--sort=-taggerdate)<output>.lines
.map(*.split(/))
.grep({ build-exists .[0] || .[1],
:force-local })
.map(*[2]);
my $cutoff = $tag-or-hash.chars max 7;
my @commits = get-output(cwd => $repo, git, rev-list,
--all, --since=2014-01-01)<output>
.lines.map(*.substr: 0, $cutoff);
# flat(@options, @tags, @commits).min: { sift4($_, $tag-or-hash, 5, 8) }
my $ans = HEAD;
my $ans_min = ∞;
for flat @options, @tags, @commits {
my $dist = sift4 $_, $tag-or-hash, $cutoff;
if $dist < $ans_min {
$ans = $_;
$ans_min = $dist;
}
}
$ans
}
#| Asks the test suite to delay the test failure (for 0.5s)
sub test-delay {
use NativeCall;
sub kill(int32, int32) is native {*};
sub getppid(--> int32) is native {*};
my $sig-compat = SIGUSR1;
# ↓ Fragile platform-specific hack
$sig-compat = 10 if $*PERL.compiler.version ≤ v2018.05;
kill getppid, +$sig-compat; # SIGUSR1
}
sub run-smth($full-commit-hash, $code, :$backend=rakudo-moar) is export {
my $build-prepath = {BUILDS-LOCATION}/$backend;
my $build-path = $build-prepath/$full-commit-hash;
my $archive-path = {ARCHIVES-LOCATION}/$backend/$full-commit-hash.zst;
my $archive-link = {ARCHIVES-LOCATION}/$backend/$full-commit-hash;
mkdir $build-prepath; # create all parent directories just in case
# (may be needed for isolated /tmp)
# lock on the destination directory to make
# sure that other bots will not get in our way.
while run(:err(Nil), mkdir, --, $build-path).exitcode ≠ 0 {
test-delay if %*ENV<TESTABLE>;
note $build-path is locked. Waiting…;
sleep 0.5 # should never happen if configured correctly (kinda)
}
if $archive-path.IO ~~ :e {
if run :err(Nil), <pzstd --version> { # check that pzstd is available
my $proc = run :out, :bin, <pzstd --decompress --quiet --stdout -->, $archive-path;
run :in($proc.out), :bin, <tar --extract --absolute-names>;
} else {
die zstd is not installed unless run :out(Nil), <unzstd --version>;
# OK we are using zstd from the Mesozoic Era
my $proc = run :out, :bin, <unzstd -qc -->, $archive-path;
run :in($proc.out), :bin, <tar --extract --absolute-names>;
}
} else {
die lrzip is not installed unless run :err(Nil), <lrzip --version>; # check that lrzip is available
my $proc = run :out, :bin, <lrzip --decompress --quiet --outfile - -->, $archive-link;
run :in($proc.out), :bin, <tar --extract --absolute-names -->, $build-path;
}
my $return = $code($build-path); # basically, we wrap around $code
rmtree $build-path;
$return
}
# TODO $default-timeout is VNNull when working in non-OOP style. Rakudobug it?
sub run-snippet($full-commit-hash, $file, :$backend=rakudo-moar, :@args=Empty,
:$timeout=$default-timeout||10, :$stdin=$default-stdin, :$ENV) is export {
run-smth :$backend, $full-commit-hash, -> $path {
my $binary-path = $path.IO.add: bin/perl6;
my %tweaked-env = $ENV // %*ENV;
%tweaked-env<PATH> = join :, $binary-path.parent, (%tweaked-env<PATH> // Empty);
%tweaked-env<PERL6LIB> = sandbox/lib;
$binary-path.IO !~~ :e
?? %(output => Commit exists, but a perl6 executable could not be built for it,
exit-code => -1, signal => -1, time => -1,)
!! get-output $binary-path, |@args,
--, $file, :$stdin, :$timeout, ENV => %tweaked-env, :!chomp
}
}
method get-commits($_, :$repo=$RAKUDO) {
return .split: /,\s*/ if .contains: ,;
if /^ $<start>=\S+ .. $<end>=\S+ $/ {
if run(:out(Nil), :err(Nil), :cwd($repo),
git, rev-parse, --verify, $<start>).exitcode ≠ 0 {
grumble Bad start, cannot find a commit for “$<start>”
}
if run(:out(Nil), :err(Nil), :cwd($repo),
git, rev-parse, --verify, $<end>).exitcode ≠ 0 {
grumble Bad end, cannot find a commit for “$<end>”
}
my $result = get-output :cwd($repo), git, rev-list, --reverse,
$<start>^..$<end>; # TODO unfiltered input
grumble Couldn't find anything in the range if $result<exit-code> ≠ 0;
my @commits = $result<output>.lines;
if @commits.elems > COMMITS-LIMIT {
grumble Too many commits ({@commits.elems}) in range, you're only allowed {COMMITS-LIMIT}
}
return @commits
}
return self.get-tags: 2015-12-24, :$repo if /:i ^ [ releases | v? 6 .? c ] $/;
return self.get-tags: 2014-01-01, :$repo if /:i ^ all $/;
return ~$<commit> if /:i ^ compare \s $<commit>=\S+ $/;
return $_
}
method get-tags($date, :$repo=$RAKUDO, :$dups=False, :@default=(HEAD,)) {
my @tags = @default;
my %seen;
for get-output(cwd => $repo, <git tag -l>)<output>.lines.reverse -> $tag {
next unless $tag ~~ /^(\d\d\d\d\.\d\d)[\.\d\d?]?$/;
next if Date.new($date) after Date.new($0.trans(.=>-)~-20);
next if $dups.not && %seen{~$0}++;
@tags.push(~$tag)
}
@tags.reverse
}
sub to-full-commit($commit, :$short=False, :$repo=$RAKUDO) is export {
return if run(:out(Nil), :err(Nil), :cwd($repo),
git, rev-parse, --verify, $commit).exitcode ≠ 0; # make sure that $commit is valid
my $result = get-output cwd => $repo,
|(git, rev-list, -1, # use rev-list to handle tags
($short ?? --abbrev-commit !! Empty), $commit);
return if $result<exit-code> ≠ 0;
return unless $result<output>;
$result<output>
}
sub write-code($code) is export {
my ($filename, $filehandle) = tempfile :!unlink;
$filehandle.print: $code;
$filehandle.close;
$filename.IO
}
sub process-gist($url, $msg) is export {
return unless $url ~~
/^ ‘https://gist.github.com/’<[a..zA..Z-]>+/(<.xdigit>**32) $/;
my $gist-id = ~$0;
my $api-url = https://api.github.com/gists/ ~ $gist-id;
my $ua = HTTP::UserAgent.new: :useragent<Whateverable>;
my $response;
try {
$response = $ua.get: $api-url;
CATCH {
grumble Cannot fetch data from GitHub API ({.message})
}
}
if not $response.is-success {
grumble Cannot fetch data from GitHub API
~ (HTTP status line is {$response.status-line})
}
my %scores; # used to determine the main file to execute
my %data = from-json $response.decoded-content;
grumble Refusing to handle truncated gist if %data<truncated>;
sub path($filename) { sandbox/$filename.IO }
for %data<files>.values {
grumble Invalid filename returned if .<filename>.contains: /|\0;
my $score = 0; # for heuristics
$score += 50 if .<language> && .<language> eq Perl 6;
$score -= 20 if .<filename>.ends-with: .pm6;
$score += 40 if !.<language> && .<content>.contains: MAIN;
my IO $path = path .<filename>;
if .<size> ≥ 10_000_000 {
$score -= 300;
grumble Refusing to handle files larger that 10 MB;
}
if .<truncated> {
$score -= 100;
grumble Can't handle truncated files yet; # TODO?
} else {
spurt $path, .<content>;
}
%scores.push: .<filename> => $score
}
my $main-file = %scores.max(*.value).key;
if $msg and %scores > 1 {
$msg.reply: Using file “$main-file” as a main file, other files are placed in “sandbox/”
}
path $main-file;
}
sub process-url($url, $msg) is export {
my $ua = HTTP::UserAgent.new: :useragent<Whateverable>;
my $response;
try {
$response = $ua.get: $url;
CATCH {
grumble It looks like a URL, but for some reason I cannot download it
~ ({.message})
}
}
if not $response.is-success {
grumble It looks like a URL, but for some reason I cannot download it
~ (HTTP status line is {$response.status-line})
}
if not $response.content-type.contains: text/plain | perl {
grumble It looks like a URL, but mime type is ‘{$response.content-type}
~ while I was expecting something with ‘text/plain’ or ‘perl’
~ in it. I can only understand raw links, sorry.
}
my $body = $response.decoded-content;
.reply: Successfully fetched the code from the provided URL with $msg;
sleep 0.02; # https://github.com/perl6/whateverable/issues/163
$body
}
method process-code($code is copy, $msg) {
$code ~~ m{^ ( ‘http’ s? ‘://’ \S+ ) }
?? process-gist(~$0, $msg) // write-code process-url(~$0, $msg)
!! write-code $code.subst: :g, , \n
}
multi method filter($response where (.encode.elems > MESSAGE-LIMIT
or ?.?additional-files
or (!~$_ and $_ ~~ ProperStr))) {
# Here $response is a Str with a lot of stuff mixed in (possibly)
my $description = Whateverable;
my $text = colorstrip $response.?long-str // ~$response;
my %files;
%files<result> = $text if $text;
%files.push: $_ with $response.?additional-files;
if $response ~~ Reply {
$description = $response.msg.server.current-nick;
%files<query> = $_ with $response.?msg.?text;
%files<query>:delete unless %files<query>;
}
my $url = self.upload: %files, public => !%*ENV<DEBUGGABLE>, :$description;
$url = $response.link-msg()($url) if $response ~~ PrettyLink;
$url
}
multi method filter($text is copy) {
ansi-to-irc($text).trans:
\n => ,
3.chr => 3.chr, 0xF.chr => 0xF.chr, # keep these for IRC colors
|((^32.chr Z=> (0x2400..*).map(*.chr)), # convert all unreadable ASCII crap
127.chr => , /<:Cc>/ =>
}
method upload(%files is copy, :$description = , Bool :$public = True) {
if %*ENV<TESTABLE> {
my $nick = $.irc.servers.values[0].current-nick;
my $gists-path = {BUILDS-LOCATION}/tist/$nick;
rmtree $gists-path if $gists-path.IO ~~ :d;
mkdir $gists-path;
spurt $gists-path/{.key}, .value for %files;
return https://whatever.able/fakeupload;
}
%files = %files.pairs.map: { .key => %( content => .value ) }; # github format
my $gist = Pastebin::Gist.new(token => $CONFIG<github><access_token> || Nil);
return $gist.paste: %files, desc => $description, public => $public
}
method selfrun($nick is copy, @alias?) {
note Bot pid: $*PID if %*ENV<TESTABLE>;
ensure-config;
use Whateverable::Builds;
ensure-cloned-repos;
$nick ~= test if %*ENV<DEBUGGABLE>;
.run with IRC::Client.new(
:$nick
:userreal($nick.tc)
:username($nick.substr(0, 3) ~ -able)
:password(?%*ENV<TESTABLE> ?? !! $CONFIG<irc><login password>.join: :)
:@alias
# IPv4 address of chat.freenode.net is hardcoded so that we can double the limit ↓
:host(%*ENV<TESTABLE> ?? 127.0.0.1 !! (chat.freenode.net, 185.30.166.38).pick)
:port(%*ENV<TESTABLE> ?? %*ENV<TESTABLE_PORT> !! 6667)
:channels(%*ENV<DEBUGGABLE>
?? #whateverable
!! %*ENV<TESTABLE>
?? #whateverable_$nick
!! (|<#perl6 #perl6-dev #zofbot #moarvm>, $CAVE) )
:debug(?%*ENV<DEBUGGABLE>)
:plugins(self)
:filters( -> |c { self.filter(|c) } )
)
}
# TODO move somewhere
# TODO commit unused
sub subprocess-commit($commit, $filename, $full-commit, :%ENV) is export {
return No build for this commit unless build-exists $full-commit;
$_ = run-snippet $full-commit, $filename, :%ENV; # actually run the code
# numbers less than zero indicate other weird failures ↓
return Cannot test this commit ($_<output>) if .<signal> < 0;
my $output = .<output>;
$output ~= «exit code = $_<exit-code>» if .<exit-code> ≠ 0;
$output ~= «exit signal = {Signal($_<signal>)} ($_<signal>)» if .<signal> ≠ 0;
$output
}
# vim: expandtab shiftwidth=4 ft=perl6
diff --git a/bin/Nativecallable.p6 b/bin/Nativecallable.p6
index 3d5ba27..58cab88 100755
--- a/bin/Nativecallable.p6
+++ b/bin/Nativecallable.p6
@@ -11,7 +11,7 @@ method help($msg) {
sub run-gptrixie($header-file) {
my %ENV = %*ENV.clone;
%ENV<PATH> = join ‘:’, ‘/home/bisectable/.rakudobrew/bin’, %ENV<PATH>; # TODO
- my %output = get-output :%ENV, ‘gptrixie’, ‘--all’, ‘--silent’, $header-file;
+ my %output = get-output :%ENV, ‘gptrixie’, '--silent', ‘--all’, ‘--castxml=c99’, $header-file;
if %output<output>.lines > 20 {
return ‘’ but FileStore(%(‘GPTrixiefied.pm6’ => "#Generated by App::GPTrixie\n" ~ %output<output>))
}
@@ -21,14 +21,15 @@ sub run-gptrixie($header-file) {
return (@pruned-output.map: {.subst(/\s+/, " ", :g)}).join: “\n”;
}
my $definitive-output //= %output<output>;
- ‘’ but FileStore(%(‘GPTrixified.pm6’ => "#Generated by App::GPTrixie\n" ~ $definitive-output))
+ ‘’ but FileStore(%(‘result.pm6’ => "#Generated by App::GPTrixie\n" ~ $definitive-output))
}
multi method irc-to-me($msg where /^ \s* $<code>=.+ /) {
my $file = self.process-code: $<code>, $msg;
my $code = slurp $file;
$file.unlink;
- my $header-file = write-code “\n#include <stddef.h>\n#include <stdbool.h>\n” ~ $code;
+ my $header-file = '/tmp/gptnc.h';
+ spurt $header-file, “\n#include <stddef.h>\n#include <stdbool.h>\n” ~ $code;
LEAVE unlink $_ with $header-file;
run-gptrixie($header-file)
}
diff --git a/bin/Shareable.p6 b/bin/Shareable.p6
index 176c670..194881a 100755
--- a/bin/Shareable.p6
+++ b/bin/Shareable.p6
@@ -24,9 +24,11 @@ use JSON::Fast;
use Cro::HTTP::Router;
use Cro::HTTP::Server;
-my $host-arch = $*KERNEL.hardware;
+#my $host-arch = $*KERNEL.hardware;
+my $host-arch = ‘x86_64’;
$host-arch = ‘amd64’|‘x86_64’ if $host-arch eq ‘amd64’|‘x86_64’;
-$host-arch = $*KERNEL.name ~ ‘-’ ~ $host-arch;
+#$host-arch = $*KERNEL.name ~ ‘-’ ~ $host-arch;
+$host-arch = ‘linux’ ~ ‘-’ ~ $host-arch;
sub cached-archive($build where ‘HEAD.tar.gz’, :$backend=‘rakudo-moar’, :$arch) {
my $repo = $backend eq ‘rakudo-moar’ ?? $RAKUDO !! MOARVM;
@@ -84,7 +86,7 @@ method help($msg) {
multi method irc-to-me($msg where /^ $<build>=[\S+] $/) {
my $full-commit = to-full-commit ~$<build>;
return ‘No build for this commit’ unless build-exists $full-commit;
- my $link = $CONFIG<mothership>;
+ my $link = $CONFIG<mothership> // $CONFIG<self>;
“$link/$<build>”
}
diff --git a/bin/build.p6 b/bin/build.p6
index a737ff8..538ff3b 100755
--- a/bin/build.p6
+++ b/bin/build.p6
@@ -37,6 +37,10 @@ my \EVERYTHING-RANGE = ‘2014.01^..HEAD’; # to build everything, but in hist
my \WORKING-DIRECTORY = ‘.’; # TODO not supported yet
+my \RAKUDO-NQP-ORIGIN = ‘https://github.com/perl6/nqp.git’;
+my \RAKUDO-NQP-LATEST = “/tmp/whateverable/rakudo-triple-nqp-repo”;
+my \RAKUDO-MOAR-ORIGIN = ‘https://github.com/MoarVM/MoarVM.git’;
+my \RAKUDO-MOAR-LATEST = “/tmp/whateverable/rakudo-triple-moar-repo”;
my \REPO-ORIGIN = RAKUDOISH
?? ‘https://github.com/rakudo/rakudo.git’
!! ‘https://github.com/MoarVM/MoarVM.git’;
@@ -60,13 +64,19 @@ exit 0 unless run ‘mkdir’, :err(Nil), ‘--’, BUILD-LOCK; # only one insta
my $locked = True;
END BUILD-LOCK.IO.rmdir if $locked;
-if REPO-LATEST.IO ~~ :d {
- my $old-dir = $*CWD;
- LEAVE chdir $old-dir;
- chdir REPO-LATEST;
- run ‘git’, ‘pull’;
-} else {
- exit unless run ‘git’, ‘clone’, ‘--’, REPO-ORIGIN, REPO-LATEST;
+sub pull-or-clone($repo-origin, $repo-path) {
+ if $repo-path.IO ~~ :d {
+ my $old-dir = $*CWD;
+ run :cwd($repo-path), ‘git’, ‘pull’;
+ } else {
+ exit unless run ‘git’, ‘clone’, ‘--’, $repo-origin, $repo-path;
+ }
+}
+
+pull-or-clone REPO-ORIGIN, REPO-LATEST;
+if RAKUDOISH {
+ pull-or-clone RAKUDO-NQP-ORIGIN, RAKUDO-NQP-LATEST;
+ pull-or-clone RAKUDO-MOAR-ORIGIN, RAKUDO-MOAR-LATEST;
}
if REPO-CURRENT.IO !~~ :d {
@@ -75,21 +85,61 @@ if REPO-CURRENT.IO !~~ :d {
my $channel = Channel.new;
-my @git-latest = ‘git’, ‘--git-dir’, “{REPO-LATEST}/.git”, ‘--work-tree’, REPO-LATEST;
-my @args-tags = |@git-latest, ‘log’, ‘-z’, ‘--pretty=%H’, ‘--tags’, ‘--no-walk’, ‘--since’, TAGS-SINCE;
-my @args-latest = |@git-latest, ‘log’, ‘-z’, ‘--pretty=%H’, COMMIT-RANGE;
-my @args-recent = |@git-latest, ‘log’, ‘-z’, ‘--pretty=%H’, ‘--all’, ‘--since’, ALL-SINCE;
-my @args-old = |@git-latest, ‘log’, ‘-z’, ‘--pretty=%H’, ‘--reverse’, EVERYTHING-RANGE;
+my @git-log = ‘git’, ‘log’, ‘-z’, ‘--pretty=%H’;
+my @args-tags = |@git-log, ‘--tags’, ‘--no-walk’, ‘--since’, TAGS-SINCE;
+my @args-latest = |@git-log, COMMIT-RANGE;
+my @args-recent = |@git-log, ‘--all’, ‘--since’, ALL-SINCE;
+my @args-old = |@git-log, ‘--reverse’, EVERYTHING-RANGE;
my %commits;
+
+# Normal Rakudo commits
for @args-tags, @args-latest, @args-recent, @args-old -> @_ {
- for run(:out, |@_).out.split(0.chr, :skip-empty) {
+ for run(:cwd(REPO-LATEST), :out, |@_).out.split(0.chr, :skip-empty) {
next if %commits{$_}:exists;
%commits{$_}++;
$channel.send: $_
}
}
+sub get-build-revision($repo, $on-commit, $file) {
+ run(:cwd($repo), :out, ‘git’, ‘show’,
+ “{$on-commit}:tools/build/$file”).out.slurp-rest.trim
+}
+
+# Rakudo-NQP-Moar triples (for bumps)
+#`「「「
+if PROJECT == Rakudo-Moar {
+ my @args-bumps = ‘git’, ‘log’, ‘-z’, ‘--pretty=%x00%H’,
+ ‘--follow’, ‘--reverse’,
+ EVERYTHING-RANGE, ‘tools/build/NQP_REVISION’;
+ for run(:cwd(REPO-LATEST), :out, |@args-bumps)
+ .out.split(0.chr, :skip-empty).rotor(2) -> ($rakudo-sha, $diff) {
+ #my $nqp-old = get-build-revision REPO-LATEST, “$rakudo-sha^”, ‘NQP_REVISION’;
+ #my $nqp-new = get-build-revision REPO-LATEST, “$rakudo-sha”, ‘NQP_REVISION’;
+
+ #say “$rakudo-sha”;
+ for run(:cwd(RAKUDO-NQP-LATEST), :out, |@git-log, “$nqp-old..$nqp-new”)
+ .out.split(0.chr, :skip-empty) -> $nqp-sha {
+ my $moar-sha = get-build-revision RAKUDO-NQP-LATEST, “$nqp-sha”, ‘MOAR_REVISION’;
+ # TODO shas are not shas
+ say “|- $nqp-sha - $moar-sha”;
+ }
+ for run(:cwd(RAKUDO-NQP-LATEST), :out, |@git-log, ‘--follow’, ‘--reverse’,
+ “$nqp-old..$nqp-new”, ‘tools/build/MOAR_REVISION’)
+ .out.split(0.chr, :skip-empty) -> $nqp-sha {
+ my $moar-old = get-build-revision RAKUDO-NQP-LATEST, “$nqp-sha^”, ‘MOAR_REVISION’;
+ my $moar-new = get-build-revision RAKUDO-NQP-LATEST, “$nqp-sha”, ‘MOAR_REVISION’;
+ for run(:cwd(RAKUDO-MOAR-LATEST), :out, |@git-log, “$moar-old..$moar-new”)
+ .out.split(0.chr, :skip-empty) -> $moar-sha {
+ say “ |- $moar-sha”;
+ }
+ }
+ }
+}
+# 」」」
+
+
await (for ^PARALLEL-COUNT { # TODO rewrite when .race starts working in rakudo
start loop {
my $commit = $channel.poll;
diff --git a/lib/Whateverable.pm6 b/lib/Whateverable.pm6
index 9eeb79b..7a2d447 100644
--- a/lib/Whateverable.pm6
+++ b/lib/Whateverable.pm6
@@ -186,7 +186,7 @@ multi method irc-to-me(Message $msg where .text ~~ /:i^ [help|usage] ‘?’? \s
multi method irc-to-me(Message $msg where .text ~~ /:i^ uptime \s* $/) {
use nqp;
use Telemetry;
- (denominate now - INIT now) ~ ‘, ’
+ (denominate now - $*INIT-INSTANT) ~ ‘, ’
~ T<max-rss>.fmt(‘%.2f’) ÷ 1024 ~ ‘MiB maxrss. ’
~ (with nqp::getcomp("perl6") {
“This is {.implementation} version {.config<version>} ”
diff --git a/services/whateverable@.service b/services/whateverable@.service
index 00aee93..3edd4b1 100644
--- a/services/whateverable@.service
+++ b/services/whateverable@.service
@@ -31,7 +31,7 @@ ReadWritePaths=/home/bisectable/git/whateverable/sandbox
ReadWritePaths=/home/bisectable/git/whateverable/data
ReadOnlyPaths=/home/bisectable/git/whateverable/data/builds
InaccessiblePaths=/home/bisectable/git/whateverable/config.json
-TemporaryFileSystem=/home/bisectable/git/whateverable/lib/.precomp
+#TemporaryFileSystem=/home/bisectable/git/whateverable/lib/.precomp
TemporaryFileSystem=/home/bisectable/git/whateverable/lib/Whateverable/.precomp
MemoryMax=1.5G
diff --git a/t/quotable.t b/t/quotable.t
index 5d72e23..820a429 100755
--- a/t/quotable.t
+++ b/t/quotable.t
@@ -43,6 +43,12 @@ $t.test(‘one message only, please’,
“{$t.our-nick}, 1 message (2015-12-26): https://whatever.able/fakeupload”,
:150timeout);
+# Timeouts
+
+$t.test(:91timeout, ‘timeout’,
+ ‘quotable6: /<before ‘’>*/’,
+ /^ <me($t)> ‘, ’ .+ <<‘exit signal’>> /);
+
# Non-bot tests
subtest ‘all channels have recent data’, {
my @tracked-channels = dir ‘data/irc’, test => { .starts-with(‘#’) && “data/irc/$_”.IO.d };
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment