Support for multifile gists

Resolves a long-standing issue #36 (but no tests yet). It works by saving all files in ‘sandbox/’, which is pretty much the only writable path. As a bonus, you should be able to use all saved files from other bots (note that all bots will now support multifile gists, so being able to reuse the files is not strictly needed). Also, this commit somewhat resolves an annoying issue #66 (support for non-raw github links), but I think we'd need to add gitlab and bitbucket in order to close it completely. How does it figure out which file should be executed? There are some heuristics in place, but generally it will prefer perl6 scripts over anything else (either use .p6 extension or include a shebang). There's no such problem when there's only one file. Note that in order to use .pm6 files you'd also need to write ｢use lib ‘sandbox/’｣.
Raku · Jun 2, 2018 · 11aa020 · 11aa020
1 parent 726cfa9
commit 11aa020
Show file tree

Hide file tree

Showing 14 changed files with 130 additions and 72 deletions.
diff --git a/bin/Benchable.p6 b/bin/Benchable.p6
@@ -59,13 +59,13 @@ multi method benchmark-code($full-commit, $filename) {
 }
 
 multi method benchmark-code($full-commit-hash, @code) {
-    my $filename = write-code ‘use Bench; my %subs = ’
+    my $file = write-code ‘use Bench; my %subs = ’
         ~ @code.kv.map({ $^k => “ => sub \{ $^v \} ” }).join(‘,’) ~ ‘;’
         ~ ‘ my $b = Bench.new; $b.cmpthese(’ ~ ITERATIONS × 2 ~ ‘, %subs)’;
-    LEAVE { unlink $_ with $filename }
+    LEAVE { unlink $_ with $file }
     my %ENV = %*ENV;
     %ENV<PERL6LIB> = “{LIB-DIR}/perl6-bench/lib,{LIB-DIR}/Perl6-Text--Table--Simple/lib”;
-    run-snippet($full-commit-hash, $filename, :%ENV)<output>
+    run-snippet($full-commit-hash, $file, :%ENV)<output>
 }
 
 multi method irc-to-me($msg where /^ \s* $<config>=([:i compare \s]? <.&commit-list>) \s+ $<code>=.+ /) {
@@ -77,8 +77,8 @@ method process($msg, $config, $code) {
     my $start-time = now;
     my $old-dir = $*CWD;
     my @commits = self.get-commits: $config;
-    my $filename = write-code self.process-code: $code, $msg;
-    LEAVE { unlink $_ with $filename }
+    my $file = self.process-code: $code, $msg;
+    LEAVE .unlink with $file;
 
     my %graph;
     my %times;
@@ -104,7 +104,7 @@ method process($msg, $config, $code) {
                 my $s = $c == 1 ?? ‘’ !! ‘s’;
                 $msg.reply: “starting to benchmark the $c given commit$s”
             }
-            my $arg = $config ~~ /:i compare / ?? $code.split: ‘|||’ !! $filename;
+            my $arg = $config ~~ /:i compare / ?? $code.split: ‘|||’ !! $file;
             %times{$short-commit} = self.benchmark-code: $full-commit, $arg;
             $actually-tested++
         }
@@ -135,7 +135,7 @@ Z:      loop (my $x = 0; $x < @commits - 1; $x++) {
                     if not build-exists $new-commit {
                         %times{$short-commit}<err> = ‘No build for this commit’
                     } elsif %times{$short-commit}:!exists and $short-commit ne @commits[$x] and $short-commit ne @commits[$x + 1] { # actually run the code
-                        %times{$short-commit} = self.benchmark-code: $new-commit, $filename;
+                        %times{$short-commit} = self.benchmark-code: $new-commit, $file;
                         @commits.splice: $x + 1, 0, $short-commit;
                         redo Z
                     }

diff --git a/bin/Bisectable.p6 b/bin/Bisectable.p6
@@ -158,9 +158,7 @@ multi method irc-to-me($msg where .text ~~ &bisect-cmd) {
     self.process: $msg, ~$code, ~$old, ~$new
 }
 
-method process($msg, $code is copy, $old, $new) {
-    $code = self.process-code: $code, $msg;
-
+method process($msg, $code, $old, $new) {
     # convert to real ids so we can look up the builds
     my @options = <HEAD>;
     my $full-old = to-full-commit $old;
@@ -179,11 +177,11 @@ method process($msg, $code is copy, $old, $new) {
     grumble “No build for revision “$new”” unless build-exists $full-new;
     my $short-new = self.get-short-commit: $new eq ‘HEAD’ ?? $full-new !! $new;
 
-    my $filename = write-code $code;
-    LEAVE { unlink $_ with $filename }
+    my $file = self.process-code: $code, $msg;
+    LEAVE .unlink with $file;
 
-    my $old-result = run-snippet $full-old, $filename;
-    my $new-result = run-snippet $full-new, $filename;
+    my $old-result = run-snippet $full-old, $file;
+    my $new-result = run-snippet $full-new, $file;
 
     grumble “Problem with $short-old commit: $old-result<output>” if $old-result<signal> < 0;
     grumble “Problem with $short-new commit: $new-result<output>” if $new-result<signal> < 0;
@@ -229,17 +227,17 @@ method process($msg, $code is copy, $old, $new) {
     my ($bisect-output, $bisect-status);
     if $old-result<signal> ≠ $new-result<signal> {
         $msg.reply: “Bisecting by exit signal (old=$short-old new=$short-new). Old exit signal: {signal-to-text $old-result<signal>}”;
-        ($bisect-output, $bisect-status) = self.run-bisect: cwd => $dir, $filename, :old-exit-signal($old-result<signal>)
+        ($bisect-output, $bisect-status) = self.run-bisect: cwd => $dir, $file, :old-exit-signal($old-result<signal>)
     } elsif $old-result<exit-code> ≠ $new-result<exit-code> {
         $msg.reply: “Bisecting by exit code (old=$short-old new=$short-new). Old exit code: $old-result<exit-code>”;
-        ($bisect-output, $bisect-status) = self.run-bisect: cwd => $dir, $filename, :old-exit-code($old-result<exit-code>)
+        ($bisect-output, $bisect-status) = self.run-bisect: cwd => $dir, $file, :old-exit-code($old-result<exit-code>)
     } else {
         if $old-result<signal> ≠ 0 {
             $msg.reply: “Bisecting by output (old=$short-old new=$short-new) because on both starting points the exit code is $old-result<exit-code> and exit signal is {signal-to-text $old-result<signal>}”
         } else {
             $msg.reply: “Bisecting by output (old=$short-old new=$short-new) because on both starting points the exit code is $old-result<exit-code>”
         }
-        ($bisect-output, $bisect-status) = self.run-bisect: cwd => $dir, $filename, :old-output($old-result<output>)
+        ($bisect-output, $bisect-status) = self.run-bisect: cwd => $dir, $file, :old-output($old-result<output>)
     }
     $msg.reply: ‘bisect log: ’ ~ self.upload: { ‘query’   => $msg.text,
                                                 ‘result’  => colorstrip(“$init-result<output>\n$bisect-output”), },

diff --git a/bin/Committable.p6 b/bin/Committable.p6
@@ -82,9 +82,8 @@ method process($msg, $config is copy, $code is copy, :%ENV) {
         $config = ‘v6.c’
     }
     my @commits = self.get-commits: $config;
-    $code = self.process-code: $code, $msg;
-    my $filename = write-code $code;
-    LEAVE { unlink $_ with $filename }
+    my $file = self.process-code: $code, $msg;
+    LEAVE .unlink with $file;
 
     my @outputs; # unlike %shas this is ordered
     my %shas;    # { output => [sha, sha, …], … }
@@ -94,7 +93,7 @@ method process($msg, $config is copy, $code is copy, :%ENV) {
         }
         @outputs.push: .key if %shas{.key}:!exists;
         .key
-    }, @commits.map: { self.process-commit: $_, $filename, :%ENV };
+    }, @commits.map: { self.process-commit: $_, $file, :%ENV };
 
     my $short-str = @outputs == 1 && %shas{@outputs[0]} > 3 && $config.chars < 20
     ?? “¦{$config} ({+%shas{@outputs[0]}} commits): «{@outputs[0]}»”

diff --git a/bin/Coverable.p6 b/bin/Coverable.p6
@@ -46,7 +46,7 @@ sub condense(@arr) { # squish into ranges
     }
 }
 
-method process($msg, $config is copy, $grep is copy, $code is copy) {
+method process($msg, $config is copy, $grep is copy, $code) {
     my $start-time = now;
 
     if $config ~~ /^ [say|sub] $/ {
@@ -57,10 +57,9 @@ method process($msg, $config is copy, $grep is copy, $code is copy) {
 
     my @commits = self.get-commits: $config;
     grumble ‘Coverable only works with one commit’ if @commits > 1;
-    $code = self.process-code: $code, $msg;
 
-    my $filename = write-code $code;
-    LEAVE { unlink $_ with $filename }
+    my $file = self.process-code: $code, $msg;
+    LEAVE .unlink with $file;
 
     my $result;
     my %lookup;
@@ -80,7 +79,7 @@ method process($msg, $config is copy, $grep is copy, $code is copy) {
         LEAVE { unlink $log }
 
         %*ENV<MVM_COVERAGE_LOG> = $log;
-        $result = run-snippet $full-commit, $filename;
+        $result = run-snippet $full-commit, $file;
         %*ENV<MVM_COVERAGE_LOG>:delete;
 
         my $g = run ‘grep’, ‘-P’, ‘--’, $grep, $log, :out;

diff --git a/bin/Evalable.p6 b/bin/Evalable.p6
@@ -49,11 +49,10 @@ multi method irc-privmsg-channel($msg) {
     self.process: $msg, $msg.args[1], :good-only
 }
 
-method process($msg, $code is copy, :$good-only?) {
+method process($msg, $code, :$good-only?) {
     my $commit = ‘HEAD’;
-    $code = self.process-code: $code, $msg;
-    my $filename = write-code $code;
-    LEAVE { unlink $_ with $filename }
+    my $file = self.process-code: $code, $msg;
+    LEAVE .unlink with $file;
 
     # convert to real id so we can look up the build
     my $full-commit  = to-full-commit $commit;
@@ -65,7 +64,7 @@ method process($msg, $code is copy, :$good-only?) {
     }
 
     # actually run the code
-    my $result = run-snippet $full-commit, $filename;
+    my $result = run-snippet $full-commit, $file;
     my $output = $result<output>;
     if $good-only and ($result<signal> ≤ 0 or $result<signal> == SIGHUP) {
         # forcefully proceed ↑ with non-zero signals (except sighupped timeouts)

diff --git a/bin/Nativecallable.p6 b/bin/Nativecallable.p6
@@ -25,7 +25,9 @@ sub run-gptrixie($header-file) {
 }
 
 multi method irc-to-me($msg where /^ \s* $<code>=.+ /) {
-    my $code = self.process-code: $<code>, $msg;
+    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;
     LEAVE unlink $_ with $header-file;
     run-gptrixie($header-file)

diff --git a/bin/Unicodable.p6 b/bin/Unicodable.p6
@@ -107,9 +107,12 @@ method from-numerics($query) {
 }
 
 method process($msg, $query is copy) {
-    my $code-response = self.process-code: $query, $msg;
-    if $code-response ne $query {
-        $query = $code-response
+    my $file = self.process-code: $query, $msg;
+    LEAVE .unlink with $file;
+
+    my $file-contents = $file.slurp;
+    if $file-contents ne $query {
+        $query = $file-contents # fetched from URL
     } elsif not $msg.args[1].match: /^ ‘.u’ \s / {
         $query = ~$0 if $msg.args[1] ~~ / <[,:]> \s (.*) / # preserve leading spaces
     }
@@ -146,13 +149,13 @@ method process($msg, $query is copy) {
     } elsif $query.starts-with: ‘{’ {
         my $full-commit = to-full-commit ‘HEAD’;
         my $output = ‘’;
-        my $filename = write-code “say join “\c[31]”, (0..0x10FFFF).grep:\n” ~ $query;
-        LEAVE { unlink $_ with $filename }
+        my $file = write-code “say join “\c[31]”, (0..0x10FFFF).grep:\n” ~ $query;
+        LEAVE unlink $_ with $file;
 
         die ‘No build for the last commit. Oops!’ unless build-exists $full-commit;
 
         # actually run the code
-        my $result = run-snippet $full-commit, $filename;
+        my $result = run-snippet $full-commit, $file;
         $output = $result<output>;
         # numbers less than zero indicate other weird failures ↓
         grumble “Something went wrong ($output)” if $result<signal> < 0;

diff --git a/lib/Whateverable.pm6 b/lib/Whateverable.pm6
@@ -172,7 +172,9 @@ multi method irc-to-me(Message $msg where .text ~~
 }
 
 multi method irc-to-me(Message $msg where .text ~~ /:i^ [stdin] [‘ ’|‘=’] $<stdin>=.* $/) {
-    $default-stdin = self.process-code: ~$<stdin>, $msg;
+    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
 }
 
@@ -279,9 +281,9 @@ sub perl6-grep($stdin, $regex is copy, :$timeout = 180, :$complex = False, :$hac
               ~ ($complex ?? ｢ nqp::substr($_, 0, nqp::index($_, “\0”)) ~~｣ !! ‘’) ~ “\n”
               ~ $regex ~ “;\n”
               ~ ｢last if $++ > ｣ ~ $GIST-LIMIT;
-    my $filename = write-code $magic;
-    LEAVE unlink $_ with $filename;
-    my $result = run-snippet $full-commit, $filename, :$timeout, :$stdin, args => (‘-np’,);
+    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;
@@ -502,11 +504,67 @@ sub write-code($code) is export {
     my ($filename, $filehandle) = tempfile :!unlink;
     $filehandle.print: $code;
     $filehandle.close;
-    $filename
+    $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;
+    my $ua = HTTP::UserAgent.new: :useragent<Whateverable>;
     my $response;
     try {
         $response = $ua.get: $url;
@@ -517,7 +575,7 @@ sub process-url($url, $msg) is export {
     }
     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}).”
+                ~ “ (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}’”
@@ -526,15 +584,15 @@ sub process-url($url, $msg) is export {
     }
 
     my $body = $response.decoded-content;
-    .reply: ‘Successfully fetched the code from the provided URL.’ with $msg;
+    .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-url(~$0, $msg)
-    !! $code.subst: :g, ‘␤’, “\n”
+    ?? 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

diff --git a/t/benchable.t b/t/benchable.t
@@ -105,25 +105,25 @@ $t.test(‘commit..commit range syntax’,
 
 $t.test(‘fetching code from urls’,
         ‘bench: HEAD https://gist.githubusercontent.com/AlexDaniel/147bfa34b5a1b7d1ebc50ddc32f95f86/raw/9e90da9f0d95ae8c1c3bae24313fb10a7b766595/test.p6’,
-        “{$t.our-nick}, Successfully fetched the code from the provided URL.”,
+        “{$t.our-nick}, Successfully fetched the code from the provided URL”,
         /^ <me($t)>‘, starting to benchmark the ’ \d+ ‘ given commit’ ‘s’? $/,
         /^ <me($t)>‘, ¦HEAD: «’ \d+\.\d+ ‘»’ $/);
 
 $t.test(‘comment after a url’,
         ‘bench: HEAD https://gist.githubusercontent.com/AlexDaniel/147bfa34b5a1b7d1ebc50ddc32f95f86/raw/9e90da9f0d95ae8c1c3bae24313fb10a7b766595/test.p6 # this is a comment’,
-        “{$t.our-nick}, Successfully fetched the code from the provided URL.”,
+        “{$t.our-nick}, Successfully fetched the code from the provided URL”,
         /^ <me($t)>‘, starting to benchmark the ’ \d+ ‘ given commit’ ‘s’? $/,
         /^ <me($t)>‘, ¦HEAD: «’ \d+\.\d+ ‘»’ $/);
 
 $t.test(‘comment after a url (without #)’,
         ‘bench: HEAD https://gist.githubusercontent.com/AlexDaniel/147bfa34b5a1b7d1ebc50ddc32f95f86/raw/9e90da9f0d95ae8c1c3bae24313fb10a7b766595/test.p6 ← like this!’,
-        “{$t.our-nick}, Successfully fetched the code from the provided URL.”,
+        “{$t.our-nick}, Successfully fetched the code from the provided URL”,
         /^ <me($t)>‘, starting to benchmark the ’ \d+ ‘ given commit’ ‘s’? $/,
         /^ <me($t)>‘, ¦HEAD: «’ \d+\.\d+ ‘»’ $/);
 
 $t.test(‘wrong url’,
         ‘bench: HEAD http://github.com/sntoheausnteoahuseoau’,
-        “{$t.our-nick}, It looks like a URL, but for some reason I cannot download it (HTTP status line is 404 Not Found).”);
+        “{$t.our-nick}, It looks like a URL, but for some reason I cannot download it (HTTP status line is 404 Not Found)”);
 
 $t.test(‘wrong mime type’,
         ‘bench: HEAD https://www.wikipedia.org/’,

diff --git a/t/bisectable.t b/t/bisectable.t
@@ -180,25 +180,25 @@ $t.test(‘␤ works like an actual newline’,
 
 $t.test(‘fetching code from urls’,
         ‘bisect: https://gist.githubusercontent.com/AlexDaniel/147bfa34b5a1b7d1ebc50ddc32f95f86/raw/9e90da9f0d95ae8c1c3bae24313fb10a7b766595/test.p6’,
-        “{$t.our-nick}, Successfully fetched the code from the provided URL.”,
+        “{$t.our-nick}, Successfully fetched the code from the provided URL”,
         /^ <me($t)>‘, On both starting points (old=2015.12 new=’<sha>‘) the exit code is 0 and the output is identical as well’ $/,
         “{$t.our-nick}, Output on both points: «url test␤»”);
 
 $t.test(‘comment after a url’,
         ‘bisect: https://gist.githubusercontent.com/AlexDaniel/147bfa34b5a1b7d1ebc50ddc32f95f86/raw/9e90da9f0d95ae8c1c3bae24313fb10a7b766595/test.p6 # this is a comment’,
-        “{$t.our-nick}, Successfully fetched the code from the provided URL.”,
+        “{$t.our-nick}, Successfully fetched the code from the provided URL”,
         /^ <me($t)>‘, On both starting points (old=2015.12 new=’<sha>‘) the exit code is 0 and the output is identical as well’ $/,
         “{$t.our-nick}, Output on both points: «url test␤»”);
 
 $t.test(‘comment after a url (without #)’,
         ‘bisect: https://gist.githubusercontent.com/AlexDaniel/147bfa34b5a1b7d1ebc50ddc32f95f86/raw/9e90da9f0d95ae8c1c3bae24313fb10a7b766595/test.p6 ← like this!’,
-        “{$t.our-nick}, Successfully fetched the code from the provided URL.”,
+        “{$t.our-nick}, Successfully fetched the code from the provided URL”,
         /^ <me($t)>‘, On both starting points (old=2015.12 new=’<sha>‘) the exit code is 0 and the output is identical as well’ $/,
         “{$t.our-nick}, Output on both points: «url test␤»”);
 
 $t.test(‘wrong url’,
         ‘bisect: http://github.com/sntoheausnteoahuseoau’,
-        “{$t.our-nick}, It looks like a URL, but for some reason I cannot download it (HTTP status line is 404 Not Found).”);
+        “{$t.our-nick}, It looks like a URL, but for some reason I cannot download it (HTTP status line is 404 Not Found)”);
 
 $t.test(‘wrong mime type’,
         ‘bisect: https://www.wikipedia.org/’,