├── .ping ├── sandbox └── answer ├── .github ├── CODEOWNERS ├── renovate.json └── workflows │ └── whateverable.yaml ├── .gitignore ├── .gitmodules ├── maintenance ├── verify-and-unbust ├── pull-uniprops ├── recompress └── fetch-irc.p6 ├── Dockerfile ├── README.md ├── xt ├── nativecallable.t ├── coverable.t ├── statisfiable.t ├── quotable.t ├── greppable.t ├── bloatable.t ├── sourceable.t ├── releasable.t ├── notable.t └── benchable.t ├── services ├── whateverable-all.service └── whateverable@.service ├── xbin ├── Nativecallable.p6 ├── Quotable.p6 ├── Committable.p6 ├── Sourceable.p6 ├── Shareable.p6 ├── Notable.p6 ├── Buildable.p6 ├── Evalable.p6 ├── Greppable.p6 ├── Bloatable.p6 ├── Coverable.p6 ├── Linkable.p6 ├── Tellable.p6 ├── Benchable.p6 └── Unicodable.p6 ├── lib ├── Whateverable │ ├── Heartbeat.pm6 │ ├── Discordable.pm6 │ ├── FootgunDB.pm6 │ ├── Configurable.pm6 │ ├── Output.pm6 │ ├── Config.pm6 │ ├── Webhooks.pm6 │ ├── Userlist.pm6 │ ├── Messages.pm6 │ ├── Uniprops.pm6 │ ├── Bits.pm6 │ ├── Running.pm6 │ ├── Bisection.pm6 │ └── Processing.pm6 └── Whateverable.pm6 ├── CONTRIBUTING.md ├── Akefile ├── META6.json └── config-default.json /.ping: -------------------------------------------------------------------------------- 1 | p1ng 2 | -------------------------------------------------------------------------------- /sandbox/answer: -------------------------------------------------------------------------------- 1 | 42 2 | -------------------------------------------------------------------------------- /.github/CODEOWNERS: -------------------------------------------------------------------------------- 1 | Dockerfile @AlexDaniel 2 | compose.yaml @AlexDaniel 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .precomp 2 | .idea 3 | data 4 | logs 5 | sandbox 6 | config.json 7 | *.swp 8 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "3rdparty/miniircd"] 2 | path = 3rdparty/miniircd 3 | url = https://github.com/jrosdahl/miniircd.git 4 | -------------------------------------------------------------------------------- /.github/renovate.json: -------------------------------------------------------------------------------- 1 | { 2 | "$schema": "https://docs.renovatebot.com/renovate-schema.json", 3 | "extends": [ 4 | "config:base", 5 | "schedule:weekends" 6 | ], 7 | "prHourlyLimit": 8 8 | } 9 | -------------------------------------------------------------------------------- /maintenance/verify-and-unbust: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | ARCHIVES_LOCATION=$1 3 | 4 | set -o pipefail 5 | 6 | echo 'Removing these builds:' 7 | for file in "$ARCHIVES_LOCATION"/*.zst; do 8 | if ! pzstd -dqc -- "$file" | tar t &> /dev/null; then 9 | echo "$file" 10 | rm -- "$file" 11 | fi 12 | done 13 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM rakudo-star:2025.04 2 | WORKDIR /srv 3 | 4 | RUN apt-get -y update 5 | RUN apt-get -y upgrade 6 | RUN apt-get -y install zstd lrzip libssl-dev build-essential 7 | 8 | RUN git config --global --add safe.directory '*' 9 | 10 | COPY META6.json /srv 11 | RUN zef install --force --/test HTTP::HPACK # to work around the dependency issue 12 | RUN zef install --force --/test --deps-only . 13 | 14 | COPY .git/ /srv/.git/ 15 | COPY . /srv 16 | -------------------------------------------------------------------------------- /maintenance/pull-uniprops: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | curl 'http://unicode.org/Public/UNIDATA/PropertyAliases.txt' | grep -Po '^[^ ]+\s+; \K[^ ]+' > uniprops 3 | echo Emoji >> uniprops 4 | echo Emoji_Presentation >> uniprops 5 | echo Emoji_Modifier >> uniprops 6 | echo Emoji_Modifier_Base >> uniprops 7 | echo Numeric_Value_Numerator >> uniprops 8 | echo Numeric_Value_Denominator >> uniprops 9 | echo NFG_QC >> uniprops 10 | echo MVM_COLLATION_PRIMARY >> uniprops 11 | echo X_SECONDARY >> uniprops 12 | echo X_TERTIARY >> uniprops 13 | echo MVM_COLLATION_QC >> uniprops 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Whateverable 2 | 3 | The Whateverables are a collection of IRC bots primarily useful for 4 | Raku developers. They are written in Raku and are based on 5 | [IRC::Client](https://github.com/lizmat/IRC-Client). Many of 6 | the use cases involve running Raku code using pre-built versions of 7 | the [Rakudo](https://github.com/rakudo/rakudo) compiler for 8 | each commit. 9 | 10 | 11 | ### Usage 12 | 13 | See [wiki](https://github.com/raku-community-modules/whateverable/wiki) for more information. 14 | 15 | 16 | ### Contributing 17 | 18 | See [CONTRIBUTING.md](CONTRIBUTING.md). 19 | 20 | 21 | ### Installation 22 | 23 | See [wiki/installation](https://github.com/raku-community-modules/whateverable/wiki/Installation). 24 | 25 | -------------------------------------------------------------------------------- /maintenance/recompress: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # ↓ Run it like this ↓ 3 | # find builds/rakudo-moar/ -mindepth 1 -maxdepth 1 -size +5M -print0 | xargs -0 -n 1 -P 5 ./maintenance/recompress 4 | 5 | ARCHIVES_LOCATION='./builds/rakudo-moar' 6 | BUILDS_LOCATION='/tmp/whateverable/rakudo-moar' 7 | 8 | archive_path=$1 9 | archive_file=${1##*/} 10 | sha=${archive_file%%.tar.zst} 11 | 12 | printf "%s\n" "$sha" 13 | zstd -q -f -d -- "$archive_path" && 14 | zstd -q -19 -i "$ARCHIVES_LOCATION/$sha" -o "$archive_path" -f 15 | rm -- "$ARCHIVES_LOCATION/$sha" # delete anyway, because can fail due to permissions 16 | 17 | 18 | # If you want to retar, use stuff below ↓ 19 | # build_path="$BUILDS_LOCATION/$sha" 20 | # zstd -dqc -- "$archive_path" | tar x --absolute-names 21 | # tar cf - --absolute-names --remove-files -- "$build_path" | zstd -c -19 -q -o "$archive_path" -f 22 | -------------------------------------------------------------------------------- /xt/nativecallable.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | BEGIN %*ENV = 1; 3 | %*ENV = 1; 4 | 5 | use lib ; 6 | use Test; 7 | use IRC::Client; 8 | use Testable; 9 | 10 | my $t = Testable.new: bot => ‘Nativecallable’; 11 | 12 | $t.common-tests: help => “Like this {$t.bot-nick}: ”; 13 | 14 | $t.shortcut-tests: , 15 | ; 16 | 17 | # Basics 18 | $t.test(‘basic struct’, 19 | “{$t.bot-nick}: ” ~ ｢struct s {int b; char* c;};｣, 20 | “{$t.our-nick}, ” 21 | ~ ｢class s is repr('CStruct') is export {␉has int32 $.b; # int b␉has Str $.c; # char* c }｣); 22 | 23 | $t.test(‘basic sub’, 24 | “{$t.bot-nick}: void foo(char *a);”, 25 | "{$t.our-nick}," ~ 'sub foo(Str $a # char*) is native(LIB) is export { * }'); 26 | 27 | $t.test-gist(‘gisted results’, 28 | %(‘Result.pm6’ => /^ ‘## Enumerations … … … … … … … … …’ $/)); 29 | 30 | $t.last-test; 31 | done-testing; 32 | END $t.end; 33 | 34 | # vim: expandtab shiftwidth=4 ft=perl6 35 | -------------------------------------------------------------------------------- /services/whateverable-all.service: -------------------------------------------------------------------------------- 1 | # Some settings don't work from user systemd, so you have to install 2 | # this file under root. See https://github.com/systemd/systemd/issues/3944 3 | 4 | [Unit] 5 | Description=All Whateverable Bots 6 | After=network-online.target 7 | Wants=whateverable@Benchable.service 8 | Wants=whateverable@Bisectable.service 9 | Wants=whateverable@Bloatable.service 10 | Wants=whateverable@Committable.service 11 | Wants=whateverable@Coverable.service 12 | Wants=whateverable@Evalable.service 13 | Wants=whateverable@Greppable.service 14 | Wants=whateverable@Linkable.service 15 | Wants=whateverable@Nativecallable.service 16 | Wants=whateverable@Notable.service 17 | Wants=whateverable@Quotable.service 18 | Wants=whateverable@Releasable.service 19 | Wants=whateverable@Reportable.service 20 | Wants=whateverable@Shareable.service 21 | Wants=whateverable@Sourceable.service 22 | Wants=whateverable@Squashable.service 23 | Wants=whateverable@Statisfiable.service 24 | Wants=whateverable@Tellable.service 25 | Wants=whateverable@Undersightable.service 26 | Wants=whateverable@Unicodable.service 27 | 28 | [Service] 29 | Type=oneshot 30 | ExecStart=/bin/true 31 | RemainAfterExit=yes 32 | 33 | [Install] 34 | WantedBy=multi-user.target 35 | -------------------------------------------------------------------------------- /xbin/Nativecallable.p6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use Whateverable; 4 | use Whateverable::Bits; 5 | use Whateverable::Output; 6 | use Whateverable::Processing; 7 | 8 | unit class Nativecallable does Whateverable; 9 | 10 | method help($msg) { 11 | “Like this {$msg.server.current-nick}: ”; 12 | } 13 | 14 | sub run-gptrixie($header-file) { 15 | my %ENV = %*ENV.clone; 16 | %ENV = join ‘:’, $*EXECUTABLE.parent, %ENV; 17 | my %output = get-output :%ENV, ‘gptrixie’, '--silent', ‘--all’, ‘--castxml=c99’, $header-file; 18 | if %output.lines > 20 { 19 | return ‘’ but FileStore(%(‘GPTrixiefied.pm6’ => "#Generated by App::GPTrixie\n" ~ %output)) 20 | } 21 | my @pruned-output; 22 | @pruned-output = %output.lines.grep: { $_ and not .starts-with: ‘#’ }; 23 | if @pruned-output ≤ 10 { 24 | return (@pruned-output.map: {.subst(/\s+/, " ", :g)}).join: “\n”; 25 | } 26 | my $definitive-output //= %output; 27 | ‘’ but FileStore(%(‘result.pm6’ => "#Generated by App::GPTrixie\n" ~ $definitive-output)) 28 | } 29 | 30 | multi method irc-to-me($msg where /^ \s* $=.+ /) { 31 | my $file = process-code $, $msg; 32 | my $code = slurp $file; 33 | $file.unlink; 34 | my $header-file = '/tmp/gptnc.h'; 35 | spurt $header-file, “\n#include \n#include \n” ~ $code; 36 | LEAVE unlink $_ with $header-file; 37 | run-gptrixie($header-file) 38 | } 39 | 40 | 41 | Nativecallable.new.selfrun: ‘nativecallable6’, [ / nativecall6? /, 42 | fuzzy-nick(‘nativecallable6’, 2) ]; 43 | -------------------------------------------------------------------------------- /lib/Whateverable/Heartbeat.pm6: -------------------------------------------------------------------------------- 1 | # Copyright © 2016-2018 2 | # Aleks-Daniel Jakimenko-Aleksejev 3 | # 4 | # This program is free software: you can redistribute it and/or modify 5 | # it under the terms of the GNU Affero General Public License as published by 6 | # the Free Software Foundation, either version 3 of the License, or 7 | # (at your option) any later version. 8 | # 9 | # This program is distributed in the hope that it will be useful, 10 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | # GNU Affero General Public License for more details. 13 | # 14 | # You should have received a copy of the GNU Affero General Public License 15 | # along with this program. If not, see . 16 | 17 | unit module Whateverable::Heartbeat; 18 | 19 | #| Tells the watchdog that we're still rolling. 20 | sub I'm-alive is export { 21 | return if %*ENV or %*ENV; 22 | use NativeCall; 23 | sub sd_notify(int32, str --> int32) is native(‘systemd’) {*}; 24 | CATCH { default { #`( it's ok, you don't need to have systemd! ) } } # AdHoc 25 | sd_notify 0, ‘WATCHDOG=1’; # this may be called too often, see TODO below 26 | } 27 | 28 | #| Asks the test suite to delay the test failure (for 0.5s) 29 | sub test-delay is export { 30 | use NativeCall; 31 | sub kill(int32, int32) is native {*}; 32 | sub getppid(--> int32) is native {*}; 33 | my $sig-compat = SIGUSR1; 34 | # ↓ TODO Fragile platform-specific hack 35 | $sig-compat = 10 if $*PERL.compiler.version ≤ v2018.05; 36 | kill getppid, +$sig-compat; # SIGUSR1 37 | } 38 | 39 | # vim: expandtab shiftwidth=4 ft=perl6 40 | -------------------------------------------------------------------------------- /services/whateverable@.service: -------------------------------------------------------------------------------- 1 | # Some settings don't work from user systemd, so you have to install 2 | # this file under root. See https://github.com/systemd/systemd/issues/3944 3 | 4 | [Unit] 5 | Description=Whateverable bot %i 6 | PartOf=whateverable-all.service 7 | 8 | [Service] 9 | Type=simple 10 | User=bisectable 11 | ExecStart=/home/bisectable/.rakudobrew/versions/moar-master/install/bin/perl6 xbin/%i.p6 12 | Environment=PERL6LIB=/home/bisectable/git/whateverable/lib 13 | #Environment=DEBUGGABLE=1 14 | WorkingDirectory=/home/bisectable/git/whateverable 15 | StandardInput=file:/home/bisectable/git/whateverable/config.json 16 | StandardOutput=journal 17 | StandardError=journal 18 | 19 | NoNewPrivileges=yes 20 | ProtectSystem=strict 21 | ProtectHome=read-only 22 | ProtectKernelTunables=yes 23 | ProtectKernelModules=yes 24 | ProtectControlGroups=yes 25 | RestrictRealtime=yes 26 | PrivateTmp=yes 27 | PrivateDevices=yes 28 | PrivateUsers=yes 29 | 30 | ReadWritePaths=/home/bisectable/git/whateverable/sandbox 31 | ReadWritePaths=/home/bisectable/git/whateverable/data 32 | ReadOnlyPaths=/home/bisectable/git/whateverable/data/builds 33 | InaccessiblePaths=/home/bisectable/git/whateverable/config.json 34 | #TemporaryFileSystem=/home/bisectable/git/whateverable/lib/.precomp 35 | TemporaryFileSystem=/home/bisectable/git/whateverable/lib/Whateverable/.precomp 36 | 37 | MemoryMax=1.5G 38 | TasksMax=200 39 | 40 | Restart=always 41 | RestartSec=2 42 | # WatchdogSec is set approximately to ping timeout 43 | # TODO ... or not. There should be at least one non-ping 44 | # message every 60 minutes or so (Issue #276) 45 | WatchdogSec=3600 46 | # TODO is exec the right option here? 47 | NotifyAccess=exec 48 | 49 | # TODO SystemCallFilter 50 | 51 | [Install] 52 | # WantedBy=multi-user.target 53 | -------------------------------------------------------------------------------- /xt/coverable.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | BEGIN %*ENV = 1; 3 | %*ENV = 1; 4 | 5 | use lib ; 6 | use Test; 7 | use IRC::Client; 8 | use Testable; 9 | 10 | my $t = Testable.new: bot => ‘Coverable’; 11 | 12 | $t.common-tests: help => “Like this: {$t.bot-nick}: f583f22 grep=SETTING:: say ‘hello’; say ‘world’”; 13 | 14 | $t.shortcut-tests: , 15 | ; 16 | 17 | # Basics 18 | 19 | $t.test(‘basic query on HEAD’, 20 | “{$t.bot-nick}: HEAD say ‘hi’”, 21 | “{$t.our-nick}, https://whatever.able/fakeupload”, 22 | :50timeout); 23 | 24 | $t.test-gist(‘basic gist test’, # let's assume say proto is not going to change 25 | %(‘result.md’ => 26 | /^^ ｢| [src/core/io_operators.pm#L｣ (\d+) ｢](https://github.com/rakudo/rakudo/blob/｣ 27 | <:hex>**40 ｢/src/core/io_operators.pm#L｣ $0 ｢) | ```proto sub say(\|) {*}``` |｣ $$/)); 28 | 29 | $t.test(‘using grep option’, 30 | “{$t.bot-nick}: 2017.06 grep=SETTING say ‘hi’”, 31 | “{$t.our-nick}, https://whatever.able/fakeupload”, 32 | :50timeout); 33 | 34 | $t.test-gist(‘stuff is filtered’, 35 | %(‘result.md’ => none / ‘/Perl6’ /)); 36 | 37 | $t.test-gist(‘the gist is not empty at all’, 38 | %(‘result.md’ => { .lines > 100})); 39 | 40 | $t.test(‘refuse more than one commit’, 41 | “{$t.bot-nick}: HEAD, HEAD^ say ‘hi’”, 42 | “{$t.our-nick}, Coverable only works with one commit”); 43 | 44 | $t.test(‘refuse a lot of commits’, 45 | “{$t.bot-nick}: releases say ‘hi’”, 46 | “{$t.our-nick}, Coverable only works with one commit”); 47 | 48 | 49 | $t.last-test; 50 | done-testing; 51 | END $t.end; 52 | 53 | # vim: expandtab shiftwidth=4 ft=perl6 54 | -------------------------------------------------------------------------------- /xt/statisfiable.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | BEGIN %*ENV = 1; 3 | %*ENV = 1; 4 | 5 | use lib ; 6 | use Test; 7 | use IRC::Client; 8 | use Testable; 9 | 10 | my $t = Testable.new: bot => ‘Statisfiable’; 11 | 12 | $t.common-tests: help => “Available stats: core (CORE.setting size), install (size of the installation), libmoar (libmoar.so size)”; 13 | 14 | $t.shortcut-tests: , 15 | ; 16 | 17 | # Basics 18 | $t.test(‘core (CORE.setting size)’, 19 | “{$t.bot-nick}: core”, 20 | “{$t.our-nick}, OK! Working on it…”, 21 | “{$t.our-nick}, https://whatever.able/fakeupload”, 22 | :120timeout); 23 | 24 | $t.test-gist(‘“core” result has some files’, 25 | %(‘plot.svg’ => True, ‘result’ => True)); 26 | 27 | $t.test(‘install (size of the installation)’, 28 | “{$t.bot-nick}: install”, 29 | “{$t.our-nick}, OK! Working on it…”, 30 | “{$t.our-nick}, https://whatever.able/fakeupload”, 31 | :120timeout); 32 | 33 | $t.test-gist(‘“install” result has some files’, 34 | %(‘plot.svg’ => True, ‘result’ => True)); 35 | 36 | $t.test(‘libmoar (libmoar.so size)’, 37 | “{$t.bot-nick}: libmoar”, 38 | “{$t.our-nick}, OK! Working on it…”, 39 | “{$t.our-nick}, https://whatever.able/fakeupload”, 40 | :120timeout); 41 | 42 | $t.test-gist(‘“libmoar” result has some files’, 43 | %(‘plot.svg’ => True, ‘result’ => True)); 44 | 45 | 46 | $t.test(‘invalid stats requested’, 47 | “{$t.bot-nick}: cakes-consumed”, 48 | /^ ‘, I cannot recognize this command. See wiki for some examples: https://’ /); 49 | 50 | 51 | $t.last-test; 52 | done-testing; 53 | END $t.end; 54 | 55 | # vim: expandtab shiftwidth=4 ft=perl6 56 | -------------------------------------------------------------------------------- /.github/workflows/whateverable.yaml: -------------------------------------------------------------------------------- 1 | name: Whateverable 2 | 3 | on: push 4 | 5 | jobs: 6 | build-and-deploy: 7 | name: whateverable (build and deploy) 8 | timeout-minutes: 25 9 | runs-on: ubuntu-latest 10 | if: github.repository == 'Raku/whateverable' 11 | steps: 12 | - name: Checkout 13 | uses: actions/checkout@v3 14 | - name: Login to Docker registry 15 | uses: docker/login-action@v2 16 | with: 17 | registry: postmodern.alexdaniel.org 18 | username: ${{ github.event.repository.name }} 19 | password: ${{ secrets.DOCKER_REGISTRY_PASSWORD }} 20 | - name: Set up Docker Buildx 21 | uses: docker/setup-buildx-action@v2 22 | - name: Build and push 23 | id: docker_build 24 | uses: docker/build-push-action@v4 25 | with: 26 | context: . 27 | cache-from: type=gha 28 | cache-to: type=gha,mode=max 29 | push: true 30 | tags: postmodern.alexdaniel.org/whateverable:${{ github.sha }} ${{ github.ref == 'refs/heads/main' && ', postmodern.alexdaniel.org/whateverable:latest' || '' }} 31 | - name: Set SSH key 32 | if: github.ref == 'refs/heads/main' 33 | uses: webfactory/ssh-agent@v0.8.0 34 | with: 35 | ssh-private-key: ${{ secrets.SSH_KEY }} 36 | - name: Auth 37 | if: github.ref == 'refs/heads/main' 38 | run: ssh-keyscan -H postmodern.alexdaniel.org >> ~/.ssh/known_hosts 39 | - name: Get config 40 | if: github.ref == 'refs/heads/main' 41 | run: scp whateverable@postmodern.alexdaniel.org:./config.json ./config.json 42 | - name: Deploy 43 | if: github.ref == 'refs/heads/main' 44 | run: docker stack deploy --with-registry-auth -c compose.yaml whateverable 45 | env: 46 | DOCKER_HOST: ssh://whateverable@postmodern.alexdaniel.org 47 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | ## How to contribute to Whateverable 2 | 3 | 🍕 First off, thanks for taking the time to contribute! 🍕 4 | 5 | 6 | If you have a question that is not covered here, just 7 | talk to a human on 8 | [#raku or #whateverable](https://webchat.freenode.net/?channels=#raku,#whateverable) 9 | IRC channel on freenode. 10 | 11 | 12 | Looking for a bug to squash? See 13 | [issues marked as low-hanging fruit](https://github.com/Raku/whateverable/issues?q=is%3Aissue+is%3Aopen+label%3A%22good+first+issue%22). 14 | 15 | 16 | ### Reporting bugs 17 | 18 | If you found a bug, feel free to 19 | [file an issue](https://github.com/Raku/whateverable/issues/new). 20 | Include as much information as you feel necessary. 21 | 22 | Note that issues are only closed once there is a fix *and* at least 23 | one test. Tickets that need tests are marked with 24 | [`testneeded`](https://github.com/Raku/whateverable/issues?q=is%3Aissue+is%3Aopen+label%3Atestneeded) 25 | label. 26 | 27 | 28 | ### Submitting changes 29 | 30 | Generally, code contributions are accepted as 31 | [pull requests](https://help.github.com/articles/about-pull-requests/). 32 | Let us know if that is not suitable for you and you want to contribute 33 | in a different way (e.g. by mailing a patch). 34 | 35 | To test your changes, check out 36 | [wiki/Installation](https://github.com/Raku/whateverable/wiki/Installation) 37 | for instructions on installing and running the bots. 38 | 39 | Coding conventions are not enforced, but try to keep your changes 40 | consistent with code around them. For example, you'll find that 41 | unicode quotes (`“”`, `‘’`, `｢｣`) are preferred over ASCII quotes 42 | (`""`, `''`), but pull requests will be accepted regardless of which 43 | quotes are used. The code will be consistified later in bulk. 44 | 45 | 46 | ### Do you want more information about the bots? 47 | 48 | If you want to learn more about the functionality of the bots, please 49 | see [whateverable wiki](https://github.com/Raku/whateverable/wiki). 50 | -------------------------------------------------------------------------------- /lib/Whateverable/Discordable.pm6: -------------------------------------------------------------------------------- 1 | # Copyright © 2019 2 | # Tobias Boege 3 | # 4 | # This program is free software: you can redistribute it and/or modify 5 | # it under the terms of the GNU Affero General Public License as published by 6 | # the Free Software Foundation, either version 3 of the License, or 7 | # (at your option) any later version. 8 | # 9 | # This program is distributed in the hope that it will be useful, 10 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | # GNU Affero General Public License for more details. 13 | # 14 | # You should have received a copy of the GNU Affero General Public License 15 | # along with this program. If not, see . 16 | 17 | use IRC::Client; 18 | 19 | my constant ChannelMessage = IRC::Client::Message::Privmsg::Channel; 20 | 21 | #| Transparently handle messages from the discord bridge. 22 | unit role Whateverable::Discordable; 23 | 24 | #| Role mixed into .nick of messages processed by Discordable 25 | my role FromDiscord is export { } 26 | 27 | #| Nick of the discord bridge bot. 28 | my constant DISCORD-BRIDGE = any(‘disbot’, ‘disbot1’, ‘disbot2’, ‘disbot11’); 29 | 30 | #| Unpack messages from the discord bridge and restart processing. 31 | multi method irc-privmsg-channel(ChannelMessage $msg where .nick eq DISCORD-BRIDGE) { 32 | # Extract the real message and sender. 33 | return $.NEXT unless $msg.text ~~ m/^ 34 | ‘<’ $=<-[>]>+ ‘>’ \s+ 35 | $=.* 36 | $/; 37 | # Since this is a channel message, we can also put the discord username 38 | # into $.nick. It is not used for routing the message on IRC, only to 39 | # address the user in the reply. 40 | my $bridged-msg = $msg.clone: 41 | nick => ~$ but FromDiscord, 42 | text => ~$, 43 | args => [$msg.channel, ~$], 44 | ; 45 | 46 | with $.irc.^private_method_table { 47 | .($.irc, $bridged-msg) 48 | } 49 | 50 | # Do nothing with the bridge's message. 51 | Nil 52 | } 53 | -------------------------------------------------------------------------------- /Akefile: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | my @bots = dir ‘xbin’, test => / ‘able.p6’ $ /; 3 | 4 | task ‘help’, { 5 | note ‘Useful commands:’; 6 | note ‘ ake debug:botname (example: ｢ake debug:bisectable｣)’; 7 | note ‘ ake kill:botname (example: ｢ake kill:committable｣)’; 8 | note ‘ ake killall’; 9 | note ‘ ake test (run the test suite)’; 10 | note ‘ ake mothership-pull (pulls the current version from the server)’; 11 | } 12 | 13 | sub to-name($_) { .extension(‘’).basename } 14 | 15 | for @bots -> $file { 16 | my $bot = to-name $file; 17 | task ‘start:’ ~ ( $bot | $bot.lc ), { 18 | note “Starting $bot…”; 19 | my $config = ‘/run/secrets/config’.IO.open || ‘config.json’.IO.open || ‘config-default.json’.IO.open; 20 | run $file, :in($config), 21 | :env(|%*ENV, PERL6LIB => ‘lib’); 22 | True 23 | } 24 | task ‘debug:’ ~ ( $bot | $bot.lc ), { 25 | note “Starting $bot in DEBUG mode…”; 26 | my $config = ‘/run/secrets/config’.IO.open || ‘config.json’.IO.open || ‘config-default.json’.IO.open; 27 | run $file, :in($config), 28 | :env(|%*ENV, PERL6LIB => ‘lib’, DEBUGGABLE => 1); 29 | True 30 | } 31 | task ‘kill:’ ~ ( $bot | $bot.lc ), { 32 | note “Killing $bot…”; 33 | my $pid = run(:out, ‘systemctl’, ‘--property=MainPID’, ‘--’, 34 | ‘show’, “whateverable@$bot.service”).out.slurp.trim; 35 | $pid .= subst: /^‘MainPID=’/, ‘’; 36 | run ‘kill’, ‘--’, $pid; 37 | True 38 | } 39 | } 40 | 41 | task ‘start-all’, { 42 | note ‘start-all is no longer needed, ’ 43 | ~ ‘systemd should start (and restart) the bots automatically’; 44 | exit 1 45 | } 46 | 47 | task $_ => @bots.map({‘kill:’ ~ to-name $_}), {;} for X~ <-all all>; 48 | task ‘test’, { run ; True } 49 | task ‘upgrade’ => ‘stop-all’, { run ‘rakudobrew’, ‘build’, ‘moar’; True } 50 | 51 | my $RSYNC = ‘bisectable@94.23.219.181:/home/bisectable/git/whateverable/’; 52 | task ‘mothership-pull’, { 53 | run ‘rsync’, ‘--archive’, ‘--verbose’, ‘--fuzzy’, ‘--compress’, 54 | ‘--human-readable’, 55 | ‘--exclude=data’, ‘--exclude=.git’, ‘--exclude=.precomp’, 56 | $RSYNC, ‘.’; 57 | True 58 | } 59 | 60 | # vim: expandtab shiftwidth=4 ft=perl6 61 | -------------------------------------------------------------------------------- /lib/Whateverable/FootgunDB.pm6: -------------------------------------------------------------------------------- 1 | # Copyright © 2018-2023 2 | # Aleks-Daniel Jakimenko-Aleksejev 3 | # 4 | # This program is free software: you can redistribute it and/or modify 5 | # it under the terms of the GNU Affero General Public License as published by 6 | # the Free Software Foundation, either version 3 of the License, or 7 | # (at your option) any later version. 8 | # 9 | # This program is distributed in the hope that it will be useful, 10 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | # GNU Affero General Public License for more details. 13 | # 14 | # You should have received a copy of the GNU Affero General Public License 15 | # along with this program. If not, see . 16 | 17 | #| Simple dumb flat file database 18 | unit class FootgunDB; 19 | 20 | use JSON::Fast; 21 | 22 | has Str $.name; 23 | has IO $!db; 24 | has Lock $!lock .= new; 25 | 26 | method TWEAK { 27 | $!db = %*ENV ?? $*TMPDIR.add($!name ~ time) !! “data/$.name”.IO; 28 | mkdir $!db.parent; 29 | self.write: %() unless $!db.e; 30 | } 31 | method clean { 32 | $!db.unlink if %*ENV 33 | } 34 | 35 | method read() { 36 | from-json slurp $!db 37 | } 38 | method write(%data) { 39 | # We will first write the data into a temporary file and then we'll rename 40 | # the file to replace the existing one. 41 | # You might be wondering – Why? 🤔 42 | # If the file system has no space available, then overwriting an existing 43 | # file will essentially trash it (leaving an empty file or a file with half 44 | # the data 🤦). Don't ask me how I know! 😭 45 | # To avoid that, we should write the data to the same file system (therefore 46 | # not /tmp, writing to the same directory with the original file is the best 47 | # bet) and then just rename the file if writing was successful. 48 | use File::Temp; 49 | my ($filename, $filehandle) = tempfile :tempdir($!db.parent), :prefix($!db.basename); 50 | spurt $filehandle, to-json :sorted-keys, %data; 51 | $filehandle.close; 52 | rename $filehandle, $!db; 53 | } 54 | method read-write(&code) { 55 | $!lock.protect: { 56 | my %data := self.read; 57 | code %data; 58 | self.write: %data 59 | } 60 | } 61 | 62 | # vim: expandtab shiftwidth=4 ft=perl6 63 | -------------------------------------------------------------------------------- /META6.json: -------------------------------------------------------------------------------- 1 | { 2 | "perl" : "6.c", 3 | "name" : "Whateverable", 4 | "version" : "1.0.12", 5 | "description" : "Different IRC bots that operate on a bunch of prebuilt Rakudo versions", 6 | "authors" : [ 7 | "Aleks-Daniel Jakimenko-Aleksejev ", 8 | "Daniel Green " 9 | ], 10 | "license" : "AGPL-3.0-or-later", 11 | "provides" : { 12 | "Whateverable" : "lib/Whateverable.pm6", 13 | "Whateverable::Bisection" : "lib/Whateverable/Bisection.pm6", 14 | "Whateverable::Bits" : "lib/Whateverable/Bits.pm6", 15 | "Whateverable::Building" : "lib/Whateverable/Building.pm6", 16 | "Whateverable::Builds" : "lib/Whateverable/Builds.pm6", 17 | "Whateverable::Config" : "lib/Whateverable/Config.pm6", 18 | "Whateverable::Configurable" : "lib/Whateverable/Configurable.pm6", 19 | "Whateverable::Discordable" : "lib/Whateverable/Discordable.pm6", 20 | "Whateverable::FootgunDB" : "lib/Whateverable/FootgunDB.pm6", 21 | "Whateverable::Heartbeat" : "lib/Whateverable/Heartbeat.pm6", 22 | "Whateverable::Messages" : "lib/Whateverable/Messages.pm6", 23 | "Whateverable::Output" : "lib/Whateverable/Output.pm6", 24 | "Whateverable::Processing" : "lib/Whateverable/Processing.pm6", 25 | "Whateverable::Running" : "lib/Whateverable/Running.pm6", 26 | "Whateverable::Uniprops" : "lib/Whateverable/Uniprops.pm6", 27 | "Whateverable::Userlist" : "lib/Whateverable/Userlist.pm6", 28 | "Whateverable::Webhooks" : "lib/Whateverable/Webhooks.pm6" 29 | }, 30 | "depends" : [ 31 | "App::GPTrixie", 32 | "Config::INI", 33 | "Cro", 34 | "Cro::HTTP::Client", 35 | "Digest", 36 | "Digest::HMAC", 37 | "Digest::SHA256::Native", 38 | "File::Directory::Tree", 39 | "File::Temp", 40 | "HTTP::Server::Async", 41 | "HTTP::UserAgent", 42 | "IO::Socket::SSL", 43 | "IRC::Client", 44 | "IRC::TextColor", 45 | "JSON::Fast", 46 | "Number::Denominate", 47 | "Pastebin::Gist", 48 | "SVG::Plot", 49 | "ake", 50 | "Stats", 51 | "Terminal::ANSIColor", 52 | "Text::Diff::Sift4" 53 | ], 54 | "resources" : [ ], 55 | "source-url" : "https://github.com/Raku/whateverable.git" 56 | } 57 | -------------------------------------------------------------------------------- /maintenance/fetch-irc.p6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | 3 | use HTTP::UserAgent; 4 | use JSON::Fast; 5 | 6 | constant $URL = ‘https://irclog.perlgeek.de’; 7 | constant @CHANNELS = <#perl6-dev #perl6 #p6dev #moarvm>; 8 | constant $PATH = ‘data/irc’.IO; 9 | 10 | my $ua = HTTP::UserAgent.new; 11 | $ua.timeout = 10; 12 | 13 | mkdir $PATH.add: $_ for @CHANNELS; 14 | 15 | sub get($channel, $date) { 16 | my $file = $PATH.add($channel).add($date); 17 | return True if $file.e; 18 | loop { 19 | my $url = “$URL/{$channel.substr: 1}/$date”; 20 | my $response = $ua.get: $url, :bin, :Accept; 21 | my $data = $response.content.decode; 22 | if not $response.is-success { 23 | if $data eq ‘{"error":"No such channel or day"}’ { 24 | note ‘That's it’; 25 | return False 26 | } 27 | note ‘Failed to get the page, retrying…’; 28 | sleep 0.5; 29 | redo 30 | } 31 | spurt $file, $data; 32 | return True; 33 | } 34 | } 35 | 36 | my $today = now.Date.pred; # always doesn't fetch the current day 37 | 38 | note ‘Fetching…’; 39 | for @CHANNELS -> $channel { 40 | note $channel; 41 | my $current-date = $today; 42 | loop { 43 | note $current-date; 44 | last unless get $channel, $current-date; 45 | $current-date .= pred; 46 | } 47 | } 48 | 49 | my num $jsontime = 0e0; 50 | my num $totaltime = 0e0; 51 | 52 | my num $starttime = now.Num; 53 | 54 | my @json_errors; 55 | 56 | note ‘Caching…’; 57 | for @CHANNELS { 58 | my @msgs; 59 | my $total; 60 | my $channel-dir = $PATH.add: $_; 61 | for $channel-dir.dir.sort.reverse { 62 | .note; 63 | my $date = .basename; 64 | try { 65 | my str $source = slurp $_; 66 | my num $start = now.Num; 67 | my $jsondata = from-json($source); 68 | $jsontime += now.Num - $start; 69 | 70 | for $jsondata.list { 71 | next without .[1]; 72 | @msgs.push: ( 73 | .[3], # what 74 | .[0], # id 75 | # .[1], # who 76 | # .[2], # when (posix) 77 | $date, 78 | ).join: “\0”; 79 | $total++ 80 | } 81 | CATCH { default { note “Skipping $date because of JSON issues $_”; @json_errors.push: $date.Str => $_.message } } 82 | } 83 | } 84 | note “Loaded $total messages”; 85 | spurt $channel-dir ~ ‘.total’, $total; 86 | spurt $channel-dir ~ ‘.cache’, @msgs.join: “\0\0” 87 | } 88 | $totaltime = now.Num - $starttime; 89 | 90 | try spurt "fetch-irc-json-errors.err", @json_errors.fmt: "%s: %s", "\n"; 91 | 92 | note "total time spent caching: $totaltime"; 93 | note "total time spent json decoding: $jsontime"; 94 | note "ratio: { $jsontime / $totaltime }"; 95 | -------------------------------------------------------------------------------- /xt/quotable.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | BEGIN %*ENV = 1; 3 | %*ENV = 1; 4 | 5 | use lib ; 6 | use Test; 7 | use IRC::Client; 8 | use Testable; 9 | 10 | my $t = Testable.new: bot => ‘Quotable’; 11 | 12 | $t.common-tests: help => “Like this: {$t.bot-nick}: /^ ‘bisect: ’ /”; 13 | 14 | $t.shortcut-tests: , 15 | ; 16 | 17 | # Basics 18 | $t.test(‘basic test’, 19 | “{$t.bot-nick}: /^ ‘bisect: ’ /”, 20 | /^ ‘, OK, working on it! This may take up to three minutes (’\d+‘ messages to process)’ $/, 21 | /^ ‘, ’\d+‘ messages (2016-05-20⌁’\d\d\d\d‘-’\d\d‘-’\d\d‘): https://whatever.able/fakeupload’/, 22 | :150timeout); 23 | 24 | $t.test-gist(‘lots of results’, 25 | %(‘result-#perl6.md’ => { 370 < .lines < 10_000 })); 26 | 27 | $t.test-gist(‘all lines match our regex’, 28 | %(‘result-#perl6.md’ => { so .lines.all.starts-with(‘[` bisect:’) })); 29 | 30 | 31 | $t.test(‘invalid regex’, 32 | “{$t.bot-nick}: ‘foo”, 33 | /^ ‘, OK, working on it! This may take up to three minutes (’\d+‘ messages to process)’ $/, 34 | “{$t.our-nick}, https://whatever.able/fakeupload”); 35 | 36 | $t.test-gist(‘error message gisted’, 37 | %(‘result’ => /^ ‘===SORRY!=== Error while compiling’ /)); 38 | 39 | 40 | $t.test(‘one message only, please’, 41 | “{$t.bot-nick}: /^ ‘pre-GLR is, like, a different language...’ /”, 42 | /^ ‘, OK, working on it! This may take up to three minutes (’\d+‘ messages to process)’ $/, 43 | “{$t.our-nick}, 1 message (2015-12-26): https://whatever.able/fakeupload”, 44 | :150timeout); 45 | 46 | # Non-bot tests 47 | subtest ‘all channels have recent data’, { 48 | my @tracked-channels = dir ‘data/irc’, test => { .starts-with(‘#’) && “data/irc/$_”.IO.d }; 49 | ok @tracked-channels > 0, ‘at least one channel is tracked’; 50 | for @tracked-channels { 51 | my $exists = “$_/{DateTime.now.earlier(:2days).Date}”.IO.e; 52 | todo ‘outdated data (issue #192)’, 3; 53 | ok $exists, “{.basename} is up-to-date (or was up-to-date 2 days ago)”; 54 | cmp-ok “$_.cache”.IO.modified.DateTime, &[>], DateTime.now.earlier(:2days), 55 | “$_ cache file was recently updated”; 56 | cmp-ok “$_.total”.IO.modified.DateTime, &[>], DateTime.now.earlier(:2days), 57 | “$_ cache file was recently updated”; 58 | } 59 | } 60 | 61 | # Timeouts 62 | 63 | $t.test(‘timeout’, 64 | ‘{$t.bot-nick}: / {sleep ∞} /’, 65 | /^ <{$t.our-nick}>‘, OK, working on it! This may take up to three minutes (’\d+‘ messages to process)’ $/, 66 | “{$t.our-nick}, timed out after 180 seconds» «exit signal = SIGHUP (1)»”, 67 | :190timeout); 68 | 69 | $t.last-test; 70 | done-testing; 71 | END $t.end; 72 | 73 | # vim: expandtab shiftwidth=4 ft=perl6 74 | -------------------------------------------------------------------------------- /xt/greppable.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | BEGIN %*ENV = 1; 3 | %*ENV = 1; 4 | 5 | use lib ; 6 | use Test; 7 | use IRC::Client; 8 | use Testable; 9 | 10 | my $t = Testable.new: bot => ‘Greppable’; 11 | 12 | $t.common-tests: help => “Like this: {$t.bot-nick}: password”; 13 | 14 | $t.shortcut-tests: , 15 | ; 16 | 17 | # Basics 18 | 19 | $t.test(:30timeout, ‘basic query’, 20 | “{$t.bot-nick}: password”, 21 | /^ ‘, ’(\d+)‘ lines, ’(\d+)‘ modules:’ 22 | { cmp-ok +~$0, &[>], +~$1, ‘more lines than modules’ } 23 | ‘ https://whatever.able/fakeupload’ $/); 24 | 25 | 26 | $t.test-gist(‘something was found’, 27 | %(‘result.md’ => /‘password’/)); 28 | 29 | $t.test-gist(‘is case insensitive’, 30 | %(‘result.md’ => /‘PASSWORD’/)); 31 | 32 | $t.test-gist(‘“…” is added to long paths’, 33 | %(‘result.md’ => /‘``…/01-basic.t``’/)); 34 | 35 | $t.test-gist(‘“…” is not added to root files’, 36 | %(‘result.md’ => none /‘``…/README.md``’/)); 37 | 38 | $t.test(‘single line/module returned’, 39 | “{$t.bot-nick}: ought to cover the same functionality as this class, maybe long-term we”, 40 | /^ ‘, 1 line, 1 module: https://whatever.able/fakeupload’ $/); 41 | 42 | $t.test(‘another query’, 43 | “{$t.bot-nick}: I have no idea”, 44 | /^ ‘, ’\d+‘ lines, ’\d+‘ modules: https://whatever.able/fakeupload’ $/); 45 | 46 | $t.test-gist(‘Proper format’, # assume that tadzik's modules don't change 47 | %(‘result.md’ => 48 | /^^ ‘| [tadzik/File-Find
``…/01-file-find.t`` :*85*:]’ 49 | ‘(https://github.com/tadzik/File-Find/blob/’ 50 | <.xdigit>**40 51 | ‘/t/01-file-find.t#L85) | exit 0; # I have no idea’ 52 | ‘ what I'm doing, but I get Non-zero exit status w/o this |’ $$/)); 53 | 54 | $t.test(:120timeout, ‘the output of git grep is split by \n, not something else’, 55 | “{$t.bot-nick}: foo”, 56 | /^ ‘, ’\d+‘ lines, ’\d+‘ modules: https://whatever.able/fakeupload’ $/); 57 | 58 | $t.test-gist(‘“\r” is actually in the output’, 59 | %(‘result.md’ => /“\r”/)); 60 | 61 | 62 | # treegrep 63 | 64 | $t.test(‘treegrep finds nothing’, 65 | ‘treegrep: theoauneoahushoauesnhoaesuheoasheoa’, 66 | “{$t.our-nick}, Found nothing!”); 67 | 68 | # Non-bot tests 69 | 70 | my $timestamp = run :out, cwd => ‘data/all-modules’, 71 | ‘git’, ‘show’, ‘-s’, ‘--format=%ct’, ‘HEAD’; 72 | 73 | ok $timestamp, ‘Got the timestamp of HEAD in data/all-modules repo’; 74 | my $age = now - $timestamp.out.slurp-rest; 75 | cmp-ok $age, &[<], 24 × 60 × 60, ‘data/all-modules repo updated in 24h’; 76 | 77 | 78 | $t.last-test; 79 | done-testing; 80 | END $t.end; 81 | 82 | # vim: expandtab shiftwidth=4 ft=perl6 83 | -------------------------------------------------------------------------------- /lib/Whateverable/Configurable.pm6: -------------------------------------------------------------------------------- 1 | # Copyright © 2018-2023 2 | # Aleks-Daniel Jakimenko-Aleksejev 3 | # 4 | # This program is free software: you can redistribute it and/or modify 5 | # it under the terms of the GNU Affero General Public License as published by 6 | # the Free Software Foundation, either version 3 of the License, or 7 | # (at your option) any later version. 8 | # 9 | # This program is distributed in the hope that it will be useful, 10 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | # GNU Affero General Public License for more details. 13 | # 14 | # You should have received a copy of the GNU Affero General Public License 15 | # along with this program. If not, see . 16 | 17 | use Whateverable::Bits; 18 | 19 | #↓ User-configurable variables for a bot 20 | unit role Whateverable::Configurable; 21 | 22 | # Keep in mind that the variables are not saved anywhere and will 23 | # be reset on bot restart. 24 | 25 | # Create a global %PROCESS::BOT-ENV variable that is 26 | # accessible as %*BOT-ENV. 27 | INIT { # XXX Total hack, but is there a better way? 28 | my %PROCESS::BOT-ENV = %*BOT-ENV // %(); # this doesn't do much 29 | %*BOT-ENV = 10; # most bots expect this 30 | } 31 | 32 | has %!default-values; #← autopopulated based on the first encountered value 33 | 34 | #↓ Resetting a variable 35 | multi method irc-to-me($msg where /^ $=@(%*BOT-ENV.keys) 36 | ‘=’ 37 | [‘’|clear|reset|delete|default] $/) { 38 | my $key = ~$; 39 | if %!default-values{$key}:!exists { 40 | # nothing to do 41 | } else { 42 | %*BOT-ENV{$key} = %!default-values{$key}; 43 | } 44 | “$key is now set to its default value “{%*BOT-ENV{$key}}”” 45 | } 46 | 47 | #↓ Setting a variable 48 | multi method irc-to-me($msg where /^ $=@(%*BOT-ENV.keys) 49 | ‘=’ 50 | $=\S+ $/) { 51 | my $key = ~$; 52 | my $value = ~$; 53 | if %!default-values{$key}:!exists { 54 | %!default-values{$key} = %*BOT-ENV{$key} 55 | } 56 | my $default-value = %!default-values{$key}; 57 | %*BOT-ENV{$key} = $value; 58 | “$key is now set to “$value” (default value is “$default-value”)” 59 | } 60 | 61 | #↓ Listing all variables 62 | multi method irc-to-me($msg where ‘variables’|‘vars’) { 63 | my @vars = %*BOT-ENV.sort(*.key); 64 | my $gist = @vars.map({.key ~ ‘=’ ~ .value}).join(‘; ’); 65 | my $table = “| Name | Value |\n|---|---|\n” 66 | ~ join “\n”, @vars.map: { “| {markdown-escape .key } |” 67 | ~ “ {markdown-escape .value} |” }; 68 | 69 | $gist but FileStore(%(‘variables.md’ => $table)) 70 | } 71 | 72 | # vim: expandtab shiftwidth=4 ft=perl6 73 | -------------------------------------------------------------------------------- /lib/Whateverable/Output.pm6: -------------------------------------------------------------------------------- 1 | # Copyright © 2016-2023 2 | # Aleks-Daniel Jakimenko-Aleksejev 3 | # Copyright © 2016 4 | # Daniel Green 5 | # 6 | # This program is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU Affero General Public License as published by 8 | # the Free Software Foundation, either version 3 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # This program is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU Affero General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU Affero General Public License 17 | # along with this program. If not, see . 18 | 19 | use Whateverable::Bits; 20 | 21 | unit module Whateverable::Output; 22 | 23 | #↓ Fancy and overwhelming way of getting stdout+stderr of a command. 24 | #↓ This is one of the most important subs in Whateverable. 25 | sub get-output(*@run-args, :$timeout = %*BOT-ENV // 10, 26 | :$stdin, :$ENV, :$cwd = $*CWD, :$chomp = True) is export { 27 | # Generally it's not a great idea to touch this sub. It works as is 28 | # and currently it is stable. 29 | my $proc = Proc::Async.new: |@run-args; 30 | 31 | my $fh-stdin; 32 | LEAVE .close with $fh-stdin; 33 | my $temp-file; 34 | LEAVE unlink $_ with $temp-file; 35 | with $stdin { 36 | if $stdin ~~ IO::Path { 37 | $fh-stdin = $stdin.open 38 | } elsif $stdin ~~ IO::Handle { 39 | $fh-stdin = $stdin 40 | } else { 41 | $temp-file = write-code $stdin; 42 | $fh-stdin = $temp-file.IO.open 43 | } 44 | $proc.bind-stdin: $fh-stdin 45 | } 46 | 47 | my $buf = Buf.new; 48 | my $result; 49 | my $s-start = now; 50 | my $s-end; 51 | react { 52 | whenever $proc.stdout :bin { $buf.push: $_ }; # RT #131763 53 | whenever $proc.stderr :bin { $buf.push: $_ }; 54 | whenever Promise.in($timeout) { 55 | $proc.kill; # TODO sends SIGHUP, but should kill the process group instead 56 | # TODO we should probably start a new process group so that it 57 | # is easier to kill afterwards 58 | $buf.push: “«timed out after $timeout seconds»”.encode; 59 | whenever Promise.in(10) { 60 | $buf.push: ‘«SIGKILL after another 10 seconds»’.encode; 61 | $proc.kill: SIGKILL 62 | } 63 | } 64 | whenever $proc.start: :$ENV, :$cwd { 65 | $result = $_; 66 | $s-end = now; 67 | done 68 | } 69 | } 70 | 71 | my $output = $buf.decode: ‘utf8-c8’; 72 | %( 73 | output => $chomp ?? $output.chomp !! $output, 74 | exit-code => $result.exitcode, 75 | signal => $result.signal, 76 | time => $s-end - $s-start, 77 | ) 78 | } 79 | -------------------------------------------------------------------------------- /lib/Whateverable/Config.pm6: -------------------------------------------------------------------------------- 1 | # Copyright © 2018-2023 2 | # Aleks-Daniel Jakimenko-Aleksejev 3 | # 4 | # This program is free software: you can redistribute it and/or modify 5 | # it under the terms of the GNU Affero General Public License as published by 6 | # the Free Software Foundation, either version 3 of the License, or 7 | # (at your option) any later version. 8 | # 9 | # This program is distributed in the hope that it will be useful, 10 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | # GNU Affero General Public License for more details. 13 | # 14 | # You should have received a copy of the GNU Affero General Public License 15 | # along with this program. If not, see . 16 | 17 | use JSON::Fast; 18 | 19 | #↓ User-configurable variables for a bot 20 | unit module Whateverable::Config; 21 | 22 | our $CONFIG is export; 23 | 24 | sub ensure-required-config-values { 25 | $CONFIG //= 390; 26 | $CONFIG //= 10_000; 27 | $CONFIG //= 500; # TODO this shouldn't be required 28 | $CONFIG //= 0; 29 | $CONFIG //= {}; 30 | $CONFIG //= ‘’; 31 | $CONFIG //= ‘’; 32 | $CONFIG //= {}; 33 | $CONFIG //= ‘’; 34 | $CONFIG //= ‘’; 35 | $CONFIG //= <#raku #raku-dev #zofbot #moarvm>; 36 | $CONFIG //= Empty; 37 | $CONFIG //= []; 38 | $CONFIG //= ‘There is no public repo yet!’; 39 | $CONFIG //= ‘There is no documentation for me yet!’; 40 | $CONFIG //= ‘’; 41 | $CONFIG //= ~$*TMPDIR.add(‘whateverable’).add(‘sandbox’); 42 | } 43 | 44 | sub ensure-config($handle = $*IN) is export { 45 | if $CONFIG { 46 | ensure-required-config-values; 47 | return; 48 | } 49 | $CONFIG //= from-json slurp $handle; 50 | ensure-required-config-values; 51 | 52 | # TODO use a special config file for tests 53 | $CONFIG = $CONFIG 54 | // ((%*ENV // ‘’).contains(‘rakudo-mock’) 55 | ?? ‘./t/data/rakudo’ !! ‘./data/rakudo-moar’); 56 | 57 | $CONFIG = $CONFIG; 58 | 59 | # TODO find a way to get rid of this code 60 | $CONFIG .= IO .= absolute; 61 | $CONFIG .= IO .= absolute; 62 | $CONFIG .= IO .= absolute; 63 | $CONFIG .= IO .= absolute; 64 | 65 | $CONFIG .= IO .= absolute; 66 | $CONFIG .= IO .= absolute; 67 | } 68 | -------------------------------------------------------------------------------- /xbin/Quotable.p6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | # Copyright © 2016-2023 3 | # Aleks-Daniel Jakimenko-Aleksejev 4 | # Copyright © 2016 5 | # Daniel Green 6 | # 7 | # This program is free software: you can redistribute it and/or modify 8 | # it under the terms of the GNU Affero General Public License as published by 9 | # the Free Software Foundation, either version 3 of the License, or 10 | # (at your option) any later version. 11 | # 12 | # This program is distributed in the hope that it will be useful, 13 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | # GNU Affero General Public License for more details. 16 | # 17 | # You should have received a copy of the GNU Affero General Public License 18 | # along with this program. If not, see . 19 | 20 | use Whateverable; 21 | use Whateverable::Bits; 22 | use Whateverable::Running; 23 | 24 | use IRC::Client; 25 | 26 | unit class Quotable does Whateverable; 27 | 28 | my $CACHE-DIR = ‘data/irc/’.IO; 29 | my $LINK = ‘https://irclog.perlgeek.de’; 30 | 31 | method help($msg) { 32 | “Like this: {$msg.server.current-nick}: /^ ‘bisect: ’ /” 33 | } 34 | 35 | my atomicint $hack = 0; 36 | multi method irc-to-me($msg where /^ \s* [ || ‘/’ $=[.*] ‘/’ 37 | || $=[.*?] ] \s* $/) { 38 | $hack ⚛= 0; 39 | my $regex = $; 40 | my $messages = $CACHE-DIR.dir(test => *.ends-with: ‘.total’)».slurp».trim».Int.sum; 41 | reply $msg, “OK, working on it! This may take up to three minutes ($messages messages to process)”; 42 | my @processed = await do for $CACHE-DIR.dir(test => *.ends-with: ‘.cache’) { 43 | my $channel = .basename.subst(/ ^‘#’ /, ‘’).subst(/ ‘.cache’$ /, ‘’); 44 | start process-channel $_, $channel, ~$regex 45 | } 46 | my $date-min = @processed».min; 47 | my $date-max = @processed».max; 48 | my $count = @processed».sum; 49 | my %channels = @processed.map: {“result-#{.}.md” => .}; 50 | return ‘Found nothing!’ unless $count; 51 | my $peek = $count > 1 ?? “$count messages ($date-min⌁$date-max)” 52 | !! “$count message ($date-min)”; 53 | (‘’ but FileStore(%channels)) but PrettyLink({“$peek: $_”}) 54 | } 55 | 56 | sub process-channel($file, $channel, $regex-str) { 57 | my $count = 0; 58 | my $date-min; 59 | my $date-max; 60 | my $gist = perl6-grep($file, $regex-str, :complex, hack => $hack⚛++).map({ 61 | my ($text, $id, $date) = .split: “\0”; 62 | $count++; 63 | $date-min min= $date; 64 | $date-max max= $date; 65 | my $backticks = ｢`｣ x (1 + ($text.comb(/｢`｣+/) || ‘’).max.chars); 66 | # TODO proper escaping 67 | $id.defined.not || $date.defined.not 68 | ?? $_ !! “[$backticks $text $backticks]($LINK/$channel/$date#i_$id)
” 69 | }).join(“\n”); 70 | $gist = ‘Found nothing!’ unless $gist; 71 | 72 | %(:$channel, :$count, :$date-min, :$date-max, :$gist) 73 | } 74 | 75 | 76 | Quotable.new.selfrun: ‘quotable6’, [ / quote6? /, 77 | fuzzy-nick(‘quotable6’, 1) ] 78 | 79 | # vim: expandtab shiftwidth=4 ft=perl6 80 | -------------------------------------------------------------------------------- /lib/Whateverable/Webhooks.pm6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | # Copyright © 2017-2023 3 | # Aleks-Daniel Jakimenko-Aleksejev 4 | # 5 | # This program is free software: you can redistribute it and/or modify 6 | # it under the terms of the GNU Affero General Public License as published by 7 | # the Free Software Foundation, either version 3 of the License, or 8 | # (at your option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU Affero General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU Affero General Public License 16 | # along with this program. If not, see . 17 | 18 | use Cro::HTTP::Router; 19 | use Cro::HTTP::Server; 20 | 21 | use Whateverable::Config; 22 | 23 | unit module Whateverable::Webhooks; 24 | 25 | 26 | class StrictTransportSecurity does Cro::Transform { 27 | has Str:D $.secret is required; 28 | has $!max-age; 29 | 30 | method consumes() { Cro::TCP::Message } 31 | method produces() { Cro::TCP::Message } 32 | 33 | method transformer(Supply $pipeline --> Supply) { 34 | supply { 35 | whenever $pipeline -> $response { 36 | $response.append-header: 37 | 'Strict-Transport-Security', 38 | "max-age=$!max-age"; 39 | emit $response; 40 | } 41 | } 42 | } 43 | } 44 | 45 | #| Listen to github webhooks. Returns a channel that will provide 46 | #| payload objects. 47 | sub listen-to-webhooks($host, $port, $secret, $channel, $irc) is export { 48 | my $c = Channel.new; 49 | 50 | my $application = route { 51 | post { 52 | my $CHANNEL = %*ENV ?? $CONFIG !! $channel; 53 | with process-webhook $secret, $CHANNEL, $irc { 54 | $c.send: $_ 55 | } 56 | } 57 | }; 58 | 59 | my $webhook-listener = Cro::HTTP::Server.new( 60 | :$host, :$port, 61 | :$application, 62 | # TODO before => WebhookChecker.new($secret) 63 | ); 64 | $webhook-listener.start; 65 | $c 66 | } 67 | 68 | #| GitHub-specific processing of webhook payloads 69 | sub process-webhook($secret, $channel, $irc) { 70 | use Digest::SHA1; 71 | use Digest::HMAC; 72 | 73 | my $body = request-body -> Blob { $_ }; 74 | dd $body; 75 | $body .= subbuf: 0..^($body - 1) if $body[*-1] == 0; # TODO trailing null byte. Why is it there? 76 | 77 | my $hmac = ‘sha1=’ ~ hmac-hex $secret, $body, &sha1; 78 | if $hmac ne request.headers { 79 | bad-request ‘text/plain’, ‘Signatures didn't match’; 80 | return 81 | } 82 | 83 | my $data = try from-json $body.decode; 84 | without $data { 85 | bad-request ‘text/plain’, ‘Signatures didn't match’; 86 | return 87 | } 88 | 89 | if $data:exists { 90 | my $text = “Webhook for {$data} is now ” 91 | ~ ($data ?? ‘active’ !! ‘inactive’) ~ ‘! ’ 92 | ~ $data; 93 | $irc.send: :$text, where => $channel; 94 | } 95 | 96 | content ‘text/plain’, ‘’; 97 | $data 98 | } 99 | 100 | # vim: expandtab shiftwidth=4 ft=perl6 101 | -------------------------------------------------------------------------------- /lib/Whateverable/Userlist.pm6: -------------------------------------------------------------------------------- 1 | # Copyright © 2016-2023 2 | # Aleks-Daniel Jakimenko-Aleksejev 3 | # 4 | # This program is free software: you can redistribute it and/or modify 5 | # it under the terms of the GNU Affero General Public License as published by 6 | # the Free Software Foundation, either version 3 of the License, or 7 | # (at your option) any later version. 8 | # 9 | # This program is distributed in the hope that it will be useful, 10 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | # GNU Affero General Public License for more details. 13 | # 14 | # You should have received a copy of the GNU Affero General Public License 15 | # along with this program. If not, see . 16 | 17 | use Whateverable::Bits; 18 | 19 | #| Keep track of users 20 | unit role Whateverable::Userlist; 21 | 22 | # This is a temporary solution (aha, sure). See this bug report: 23 | # * https://github.com/zoffixznet/perl6-IRC-Client/issues/29 24 | 25 | # We'll need at least one lock no matter what, so let's 26 | # use *just* one to make things simpler 27 | has %!userlist; #= %( channel0 => %(:user0, …), … ); 28 | has $!userlist-lock = Lock.new; 29 | 30 | method userlist($msg) { 31 | $!userlist-lock.protect: { 32 | %!userlist{$msg.channel} // %() 33 | } 34 | } 35 | 36 | #| Impersonate other bots 37 | method make-believe($msg, @nicks, &play) { 38 | my @found-nicks = self.userlist($msg){@nicks}:exists; 39 | if @found-nicks.none { 40 | $_ but Reply($msg) with play; 41 | } 42 | } 43 | 44 | #| Nick change event 45 | method irc-nick($event) { 46 | $!userlist-lock.protect: { 47 | for %!userlist.keys -> $channel { 48 | %!userlist{$channel}{$event.nick}:delete; 49 | %!userlist{$channel}{$event.new-nick} = True; 50 | } 51 | } 52 | $.NEXT 53 | } 54 | method irc-join($event) { 55 | $!userlist-lock.protect: { 56 | if not %!userlist{$event.channel} or (^30).pick == 0 { # self-healing behavior 57 | $event.irc.send-cmd: ‘NAMES’, $event.channel; 58 | } 59 | %!userlist{$event.channel}{$event.nick} = True; 60 | } 61 | $.NEXT 62 | } 63 | method irc-part($event) { 64 | $!userlist-lock.protect: { 65 | %!userlist{$event.channel}{$event.nick}:delete; 66 | } 67 | $.NEXT 68 | } 69 | method irc-quit($event) { 70 | $!userlist-lock.protect: { 71 | for %!userlist.keys -> $channel { 72 | %!userlist{$channel}{$event.nick}:delete; 73 | } 74 | } 75 | $.NEXT 76 | } 77 | 78 | has %!userlist-temp; # for storing partial messages 79 | 80 | #| Receive a user list (one or more messages) 81 | method irc-n353($event) { 82 | my $channel = $event.args[2]; 83 | # Try to filter out privileges ↓ 84 | my @nicks = $event.args[3].words.map: { m/ (<.&irc-nick>) $ /[0].Str }; 85 | $!userlist-lock.protect: { 86 | %!userlist-temp{$channel}{@nicks} = True xx @nicks 87 | } 88 | } 89 | 90 | # XXX What if we receive a `join` right here? Whatever… 91 | 92 | #| Receive a user list (final message) 93 | method irc-n366($event) { 94 | my $channel = $event.args[1]; 95 | $!userlist-lock.protect: { 96 | %!userlist{$channel} = %!userlist-temp{$channel}; 97 | %!userlist-temp{$channel}:delete 98 | } 99 | } 100 | 101 | # vim: expandtab shiftwidth=4 ft=perl6 102 | -------------------------------------------------------------------------------- /xt/bloatable.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | BEGIN %*ENV = 1; 3 | %*ENV = 1; 4 | 5 | use lib ; 6 | use Test; 7 | use IRC::Client; 8 | use Testable; 9 | 10 | my $t = Testable.new: bot => ‘Bloatable’; 11 | 12 | $t.common-tests: help => “Like this: {$t.bot-nick}: d=compileunits 292dc6a,HEAD”; 13 | 14 | $t.shortcut-tests: , 15 | ; 17 | 18 | # Basics 19 | 20 | $t.test(‘one commit’, 21 | “{$t.bot-nick}: HEAD”, 22 | “{$t.our-nick}, https://whatever.able/fakeupload”); 23 | 24 | $t.test-gist(‘actual sha is mentioned’, 25 | %(‘result’ => /^ ‘HEAD(’‘)’ /)); 26 | 27 | $t.test-gist(‘something in the output’, 28 | %(‘result’ => / ‘TOTAL’ /)); 29 | 30 | 31 | $t.test(‘two commits’, 32 | “{$t.bot-nick}: 2017.01,HEAD”, 33 | “{$t.our-nick}, https://whatever.able/fakeupload”); 34 | 35 | $t.test-gist(‘compares A and B’, 36 | %(‘result-00001’ => /^ ‘Comparing 2017.01 → HEAD(’‘)’ $$/)); 37 | 38 | $t.test-gist(‘something is shrinking’, 39 | %(‘result-00001’ => / ‘SHRINKING’ /)); 40 | 41 | $t.test-gist(‘something is growing’, 42 | %(‘result-00001’ => / ‘GROWING’ /)); 43 | 44 | 45 | $t.test(‘three commits’, 46 | “{$t.bot-nick}: 2017.01,2017.05,HEAD”, 47 | “{$t.our-nick}, https://whatever.able/fakeupload”); 48 | 49 | $t.test-gist(‘compares A → B and B → C’, 50 | %(‘result-00001’ => /^ ‘Comparing 2017.01 → 2017.05’ $$/, 51 | ‘result-00002’ => /^ ‘Comparing 2017.05 → HEAD(’‘)’ $$/)); 52 | 53 | 54 | $t.test(‘older commits’, 55 | “{$t.bot-nick}: 2016.01,2017.01”, 56 | “{$t.our-nick}, https://whatever.able/fakeupload”); 57 | 58 | $t.test-gist(‘the output is reasonably-sized and consistent’, 59 | %(‘result-00001’ => { .lines == 89 })); 60 | 61 | 62 | $t.test(‘different source (using -d …)’, 63 | “{$t.bot-nick}: -d inputfiles 2016.01,2017.01”, 64 | “{$t.our-nick}, https://whatever.able/fakeupload”); 65 | 66 | $t.test-gist(‘the output is indeed different for -d inputfile’, 67 | %(‘result-00001’ => { .lines == 9 })); 68 | 69 | $t.test(‘different sources (using -d …)’, 70 | “{$t.bot-nick}: -d inputfiles,sections 2016.01,2017.01”, 71 | “{$t.our-nick}, https://whatever.able/fakeupload”); 72 | 73 | $t.test-gist(‘the output is indeed different for -d inputfile,sections’, 74 | %(‘result-00001’ => { .lines == 87 })); 75 | 76 | 77 | $t.test(‘different source (using d=…)’, 78 | “{$t.bot-nick}: d=inputfiles 2016.01,2017.01”, 79 | “{$t.our-nick}, https://whatever.able/fakeupload”); 80 | 81 | $t.test-gist(‘the output is indeed different for dsinputfile’, 82 | %(‘result-00001’ => { .lines == 9 })); 83 | 84 | $t.test(‘different sources (using d=…)’, 85 | “{$t.bot-nick}: d=inputfiles,sections 2016.01,2017.01”, 86 | “{$t.our-nick}, https://whatever.able/fakeupload”); 87 | 88 | $t.test-gist(‘the output is indeed different for dsinputfile,sections’, 89 | %(‘result-00001’ => { .lines == 87 })); 90 | 91 | 92 | $t.test(‘incorrect source (using -d …)’, 93 | “{$t.bot-nick}: -duhmm… 2017.01,HEAD”, 94 | /^ ‘, No such data source: uhmm… (Did you mean one of these: ’ [\w+]+ % \s+ ‘ ?)’ $/); 95 | 96 | $t.test(‘incorrect source (using d=…)’, 97 | “{$t.bot-nick}: d=uhmm… 2017.01,HEAD”, 98 | /^ ‘, No such data source: uhmm… (Did you mean one of these: ’ [\w+]+ % \s+ ‘ ?)’ $/); 99 | 100 | 101 | $t.last-test; 102 | done-testing; 103 | END $t.end; 104 | 105 | # vim: expandtab shiftwidth=4 ft=perl6 106 | -------------------------------------------------------------------------------- /xbin/Committable.p6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | # Copyright © 2016-2023 3 | # Aleks-Daniel Jakimenko-Aleksejev 4 | # Copyright © 2016 5 | # Daniel Green 6 | # 7 | # This program is free software: you can redistribute it and/or modify 8 | # it under the terms of the GNU Affero General Public License as published by 9 | # the Free Software Foundation, either version 3 of the License, or 10 | # (at your option) any later version. 11 | # 12 | # This program is distributed in the hope that it will be useful, 13 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | # GNU Affero General Public License for more details. 16 | # 17 | # You should have received a copy of the GNU Affero General Public License 18 | # along with this program. If not, see . 19 | 20 | use Whateverable; 21 | use Whateverable::Bits; 22 | use Whateverable::Builds; 23 | use Whateverable::Processing; 24 | use Whateverable::Running; 25 | 26 | use IRC::Client; 27 | 28 | unit class Committable does Whateverable; 29 | 30 | constant TOTAL-TIME = 60 × 10; 31 | constant shortcuts = %( 32 | mc => ‘2015.12’, ec => ‘2015.12’, 33 | mch => ‘2015.12,HEAD’, ech => ‘2015.12,HEAD’, 34 | ma => ‘all’, all => ‘all’, 35 | what => ‘6c’, ‘6c’ => ‘6c’, ‘v6c’ => ‘6c’, ‘v6.c’ => ‘6c’, ‘6.c’ => ‘6c’, 36 | releases => ‘releases’, 37 | ); 38 | 39 | # https://github.com/rakudo/rakudo/wiki/dev-env-vars 40 | my \ENV-VARS = set ; 43 | 44 | method help($msg) { 45 | “Like this: {$msg.server.current-nick}: f583f22,HEAD say ‘hello’; say ‘world’” 46 | } 47 | 48 | multi method irc-to-me($msg where .args[1] ~~ ?(my $prefix = m/^ $=@(shortcuts.keys) 49 | [‘:’ | ‘,’]/) 50 | && .text ~~ /^ \s* $=.+ /) is default { 51 | my $code = ~$; 52 | my $shortcut = shortcuts{$prefix}; 53 | start process $msg, $shortcut, $code 54 | } 55 | 56 | multi method irc-to-me($msg where /^ \s* [ @=((<[\w-]>+)‘=’(\S*)) ]* %% \s+ 57 | $=<.&commit-list> \s+ 58 | $=.+ /) { 59 | my %ENV = @.map: { ~.[0] => ~.[1] } if @; 60 | for %ENV { 61 | grumble “ENV variable {.key} is not supported” if .key ∉ ENV-VARS; 62 | grumble “ENV variable {.key} can only be 0, 1 or empty” if .value ne ‘0’ | ‘1’ | ‘’; 63 | } 64 | %ENV ,= %*ENV; 65 | my $config = ~$; 66 | my $code = ~$; 67 | start process $msg, $config, $code, :%ENV 68 | 69 | } 70 | 71 | sub process($msg, $config is copy, $code is copy, :%ENV) { 72 | my $start-time = now; 73 | if $config ~~ /^ [say|sub] $/ { 74 | reply $msg, “Seems like you forgot to specify a revision (will use “v6.c” instead of “$config”)”; 75 | $code = “$config $code”; 76 | $config = ‘v6.c’ 77 | } 78 | my @commits = get-commits $config; 79 | my $file = process-code $code, $msg; 80 | LEAVE .unlink with $file; 81 | 82 | my @outputs; # unlike %shas this is ordered 83 | my %shas; # { output => [sha, sha, …], … } 84 | 85 | proccess-and-group-commits @outputs, %shas, $file, @commits, 86 | :intermingle, :!prepend, 87 | :$start-time, time-limit => TOTAL-TIME, 88 | :%ENV; 89 | 90 | commit-groups-to-gisted-reply @outputs, %shas, $config; 91 | } 92 | 93 | 94 | Committable.new.selfrun: ‘committable6’, [ / [ | c [ommit]?6? 95 | | @(shortcuts.keys) ] /, 96 | fuzzy-nick(‘committable6’, 3) ] 97 | 98 | # vim: expandtab shiftwidth=4 ft=perl6 99 | -------------------------------------------------------------------------------- /config-default.json: -------------------------------------------------------------------------------- 1 | { 2 | "projects": { 3 | "rakudo-moar": { 4 | "repo-origin": "https://github.com/rakudo/rakudo", 5 | "repo-path": "./data/rakudo-moar", 6 | "archives-path": "./data/builds/rakudo-moar" 7 | }, 8 | "moarvm": { 9 | "repo-origin": "https://github.com/MoarVM/MoarVM", 10 | "repo-path": "./data/moarvm", 11 | "archives-path": "./data/builds/moarvm" 12 | } 13 | }, 14 | "builds-location" : "/tmp/whateverable/", 15 | "sandbox-path" : "./sandbox", 16 | 17 | "source" : "https://github.com/Raku/whateverable", 18 | "wiki" : "https://github.com/Raku/whateverable/wiki/", 19 | 20 | "message-limit" : 390, 21 | "gist-limit" : 10000, 22 | "commits-limit" : 500, 23 | "cave" : "#whateverable", 24 | "caregivers" : [ "AlexDaniel", "MasterDuke" ], 25 | 26 | "mothership": "https://whateverable.6lang.org", 27 | 28 | "github": { 29 | "login": "", 30 | "access_token": "" 31 | }, 32 | "irc": { 33 | "login": "", 34 | "password": "" 35 | }, 36 | "buildable": { 37 | "host" : "0.0.0.0", 38 | "port" : 42435 39 | }, 40 | "bisectable": { 41 | "commit-link" : "https://github.com/rakudo/rakudo/commit", 42 | "build-lock" : "./lock", 43 | "trim-chars" : 2000 44 | }, 45 | "squashable": { 46 | "host": "", 47 | "port": 4243, 48 | "secret": "" 49 | }, 50 | "reportable": { 51 | "RT": { 52 | "user": "", 53 | "pass": "" 54 | } 55 | }, 56 | "shareable": { 57 | "host": "localhost", 58 | "port": 42434 59 | }, 60 | "releasable": { 61 | "spammed-channels": ["#raku-dev", "#whateverable"], 62 | "spam-before": 604800, 63 | "spam-every": 72000, 64 | "spam-exception-delay": 3600 65 | }, 66 | 67 | "default-stdin": "♥\uD83E\uDD8B ꒛㎲₊⼦\uD83C\uDCB4⧿⌟ⓜ≹℻ \uD83D\uDE26⦀\uD83C\uDF35 \uD83D\uDDB0㌲⎢➸ \uD83D\uDC0D\uD83D\uDC94 \uD83D\uDDED\uD800\uDD79⮟⿁ ⡍㍷⽐\n\uD83C\uDF27\uD83D\uDEAD✒\uD83E\uDC77᭵\uD834\uDC4A◓⚐\uD83D\uDFD3\uD83E\uDC28 ⨱≌ ◫ ☌┃\uD83C\uDC15⌆\uD834\uDD10㊑\uD83D\uDE74\uD83C\uDC29 hello world ≮\uD83D\uDC1B \uD83C\uDC0E \uD83D\uDE6A⫤\uD83D\uDD69╤\uD834\uDCBF\uD834\uDDB6\uD83D\uDEE0 \uD83C\uDF28␠⠉⬴᭴\uD800\uDD3D ⼈\uD834\uDC0F \uD834\uDDA2⽹ ┉⫤⣲؆ ⼏☰⮚\uD83C\uDF4B\uD83C\uDD63\uD83E\uDC43\uD83E\uDC98✲\n\uD83D\uDD38㋪⚈ \uD83C\uDE2B⛋⌺\uD800\uDDDE⨿ ⑅ ◸⡢\uD83D\uDC35⨴\uD834\uDE27 ᭻\uD83E\uDC38└ⓖ⏑ Ⅵ ⊢✡\uD834\uDF11 \uD83C\uDD14◣⮥ \uD83D\uDE74 ⻊㌏\uD835\uDEDB⬱\uD83D\uDDDE㋻\uD83D\uDFA5 \uD83E\uDC21☑\uD83D\uDDF9✜ ⣑ ㎀\uD83D\uDE3D⊈㎄\n\uD834\uDE3E\uD83D\uDD5F \uD83D\uDD85 ⇲⮬\uD834\uDCB3 ℅⫺⮉╫±⫍⋌ ⊱࿀\uD83D\uDD85 Ⓧ\uD834\uDC3C\uD83C\uDCC8 \uD83D\uDE1A\uD834\uDE23\uD83C\uDFCD\uD83C\uDE33℡ \uD83D\uDF01⁒➞ ⊫\uD83D\uDD9C⟜\uD834\uDD3C\n\uD83D\uDE85\uD83C\uDD18\uD83D\uDCF9\uD83D\uDF55 ⽮⎆㆑ 4\uD835\uDFEE \uD83D\uDF07❑ ⏢ \uD83D\uDF05\uD834\uDD4F㋸❎≜⬥\n\uD800\uDDDC▬⨐\uD83D\uDD19⼃ ▟\uD83E\uDCA0　\uD83D\uDCD8 ½ ≬⣥⮨㌥㈱ \uD834\uDC84\uD83C\uDC57 ␊\uD834\uDF09⡂\uD83D\uDE6A⢎ ▙\uD83C\uDF41⾤ ⣌ \uD83D\uDC18 \uD83D\uDD79\uD800\uDD7D⎨᧣ ⣄∇　䷲⾡▇⼸ ⺖ \uD834\uDD58\uD834\uDD65\uD834\uDD72\uD834\uDCBE\uD83C\uDE11✩⠡\n␀꓄\uD83C\uDE43 \uD83D\uDD0C\uD83D\uDCAD ㈰\uD83C\uDC4D⩟⏛℧\uD834\uDCBC⪵　∪\uD83C\uDE13؇⽖\uD83D\uDDFB⤽ ⛍ \uD83C\uDF67☓ ⢾⭹㇈⧨\uD83C\uDD95⻍⌃\uD83D\uDDF3⠀ ⫠\uD834\uDCD8\uD834\uDC9D\uD83C\uDF2E\uD83C\uDC42\uD834\uDF08⇲\uD83D\uDEB7\uD83D\uDF27\n┌ⓤ⩠☫⎶⬝ \uD83D\uDC9F\uD83D\uDECD\uD83D\uDCDF \uD83D\uDCE3\uD83D\uDE61 \uD834\uDCDE⣰\uD834\uDD09␥⼉ ╸⥸㍤ \uD83E\uDC1C\uD83D\uDF26⊃\uD83E\uDC82؏⣒\uD83C\uDC6A䷓ \uD834\uDC46\uD83C\uDFAE᧶⦵\uD83C\uDC45　\uD83D\uDFA6\uD83E\uDC9A　⣺⌝\uD83C\uDD23\uD834\uDD47⢛\uD834\uDCAB⬄\n\uD834\uDE2A⒡⩜䷹\uD83D\uDDDC㌧ \uD834\uDD5A ┐⠾᧞⭺⺥⫔\uD83C\uDCA1❙\uD83C\uDD7B\uD834\uDF46 \uD834\uDE08❧\uD83C\uDCAD㉹↗\uD83C\uDF1C➾⌸\uD83C\uDE2F ⾓\uD83D\uDDCF↴ ≩✿ ⫰\uD83E\uDC9E　⬛\uD83D\uDF2A№♹♌࿂　\uD834\uDF14⪕\uD83C\uDD5A⇸∇ ⥯\uD83D\uDD12\uD83D\uDCDD\uD83C\uDD4D﹥㊦\uD83C\uDDEA⩃\uD83C\uDD38\n⼲\uD83C\uDF8A✳ \uD83C\uDF2D ㏇╙⭋ \uD83C\uDF60⪘⚣\uD834\uDC84㌡ ⋉㎌ \uD83D\uDCFB\uD83D\uDFC0 ⨩◭㏝\uD83C\uDC7B\uD83D\uDC13♆⣨\uD834\uDCAB \uD83C\uDCAB\uD834\uDF22᧢≼\uD834\uDCDB\uD83E\uDC02㇝♵➥\uD834\uDCC1 ⢘⢯\uD83C\uDC7F⩁⺜᭸⾲㇏\n" 68 | } 69 | -------------------------------------------------------------------------------- /xbin/Sourceable.p6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | # Copyright © 2019-2023 3 | # Aleks-Daniel Jakimenko-Aleksejev 4 | # Copyright © 2019 5 | # Alexander Kiryuhin 6 | # 7 | # This program is free software: you can redistribute it and/or modify 8 | # it under the terms of the GNU Affero General Public License as published by 9 | # the Free Software Foundation, either version 3 of the License, or 10 | # (at your option) any later version. 11 | # 12 | # This program is distributed in the hope that it will be useful, 13 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | # GNU Affero General Public License for more details. 16 | # 17 | # You should have received a copy of the GNU Affero General Public License 18 | # along with this program. If not, see . 19 | 20 | use Whateverable; 21 | use Whateverable::Bits; 22 | use Whateverable::Builds; 23 | use Whateverable::Output; 24 | use Whateverable::Running; 25 | 26 | unit class Sourceable does Whateverable; 27 | 28 | my $BLOB-URL = ‘https://github.com/rakudo/rakudo/blob’; 29 | 30 | method help($msg) { 31 | “Like this: {$msg.server.current-nick}: 42.base(16)” 32 | } 33 | 34 | multi method irc-to-me($msg where { .Str ~~ m:r/^ [$=\S+ \s+]? $=[.+] $/ }) { 35 | my $full-commit = to-full-commit $ // ‘’; 36 | my $code = ~$; 37 | if not $full-commit { 38 | $full-commit = to-full-commit ‘HEAD’; 39 | $code = ~$/; 40 | } 41 | my $short-commit = get-short-commit $full-commit; 42 | grumble “No build for revision “$short-commit”” unless build-exists $full-commit; 43 | 44 | # Leave the build unpacked 45 | my $build-unpacked = 46 | run-smth $full-commit, {True}, :!wipe, :lock; 47 | LEAVE { run-smth $full-commit, {; }, :wipe, :!lock with $build-unpacked } 48 | 49 | my @wild-guesses = gather { 50 | take $code; # code object (as-is) 51 | take ‘&’ ~ $code; # sub 52 | # method 53 | for $code ~~ m:ex/^ (.+) ‘.’ (.+) $/ -> $/ { 54 | take “{$0}.^can(‘$1’)[0]” 55 | } 56 | # sub with args 57 | for $code ~~ m:ex/^ (.+) [ \s+ (.*) | ‘(’ (.*) ‘)’ ] $/ -> $/ { 58 | take ｢&%s.cando(\(%s))[0]｣.sprintf: $0, $1 // $2 59 | } 60 | # method with args 61 | for $code ~~ m:ex/^ (.+) ‘.’ (<[\w-]>+) [ [‘: ’ (.*)] | [‘(’ (.*) ‘)’]? ] $/ -> $/ { 62 | take ｢(%s).^can(‘%s’).map(*.cando(\((%s), |\(%s)))).first(*.so)[0]｣.sprintf: $0, $1, $0, $2 // $3 // ‘’ 63 | } 64 | # infix operators 65 | for $code ~~ m:ex/^ (.+) \s+ (\S+) \s+ (.+) $/ -> $/ { 66 | take ｢&[%s].cando(\(%s, %s))[0]｣.sprintf: $1, $0, $2 67 | } 68 | # yeah, just some useful heuristics and brute force 69 | # ideally, it should work with QAST 70 | } 71 | 72 | for @wild-guesses -> $tweaked-code { 73 | my $wrapped-code = ‘with {’ ~ $tweaked-code ~ ‘}() { print “\0\0” ~ .line ~ “\0\0” ~ .file ~ “\0\0” }’; 74 | my $file = write-code $wrapped-code; 75 | LEAVE .unlink with $file; 76 | 77 | my $result = run-snippet $full-commit, $file, :!wipe, :!lock; 78 | if $result == 0 { 79 | my ($, $line, $file, $) = $result.split: “\0\0”, 4; # hackety hack 80 | if $line and $file and $file.starts-with: ‘SETTING::’ { 81 | $file .= subst: /^‘SETTING::’/, ‘’; 82 | return “$BLOB-URL/$short-commit/$file#L$line”; 83 | } 84 | } 85 | } 86 | # Test the snippet itself 87 | my $file = write-code $code; 88 | my $result = run-snippet $full-commit, $file, :!wipe, :!lock; 89 | my $cry = ‘No idea, boss. Can you give me a Code object?’; 90 | if $result ≠ 0 { 91 | return (“$cry Output: {$result}” 92 | but ProperStr($result)) but PrettyLink({“$cry Output: $_”}) 93 | } 94 | return $cry 95 | } 96 | 97 | 98 | Sourceable.new.selfrun: 'sourceable6', [ / s /, 99 | fuzzy-nick('sourceable6', 2) ]; 100 | -------------------------------------------------------------------------------- /xt/sourceable.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | BEGIN %*ENV = 1; 3 | %*ENV = 1; 4 | 5 | use lib ; 6 | use Test; 7 | use Testable; 8 | 9 | my $t = Testable.new: bot => 'Sourceable'; 10 | 11 | $t.common-tests: help => “Like this: {$t.bot-nick}: 42.base(16)”; 12 | 13 | $t.shortcut-tests: (‘s:’, ), 14 | ; 15 | 16 | my $link = ‘https://github.com/rakudo/rakudo/blob/’; 17 | 18 | $t.test(‘code object’, 19 | “{$t.bot-nick}: ©”, 20 | /$link .+? ‘src/core.c/io_operators.pm6’/); 21 | 22 | $t.test(‘sub without ampersand’, 23 | “{$t.bot-nick}: copy”, 24 | /$link .+? ‘src/core.c/io_operators.pm6’/); 25 | 26 | $t.test(‘sub with args (parens)’, 27 | “{$t.bot-nick}: ” ~ ｢sprintf('<%#B>', 12)｣, 28 | /$link .+? ‘src/core.c/Cool.pm6’/); 29 | 30 | $t.test(‘sub with args no parens’, 31 | “{$t.bot-nick}: ” ~ ｢sprintf '<%#B>', 12｣, 32 | /$link .+? ‘src/core.c/Cool.pm6’/); 33 | 34 | $t.test(‘method on type’, 35 | “{$t.bot-nick}: Int.base”, 36 | /$link .+? ‘src/core.c/Int.pm6’/); 37 | 38 | $t.test(‘method on object’, 39 | “{$t.bot-nick}: 42.3.base”, 40 | /$link .+? ‘src/core.c/Rational.pm6’/); 41 | 42 | $t.test(‘method with args (parens)’, 43 | “{$t.bot-nick}: 42.base(16)”, 44 | /$link .+? ‘src/core.c/Int.pm6’/); 45 | 46 | $t.test(‘method with args: colon’, 47 | “{$t.bot-nick}: 42.base: 16”, 48 | /$link .+? ‘src/core.c/Int.pm6’/); 49 | 50 | $t.test(‘operator’, 51 | “{$t.bot-nick}: ” ~ ｢&infix:['+<']｣, 52 | /$link .+? ‘src/core.c/Numeric.pm6’/); 53 | 54 | $t.test(‘operator with args’, 55 | “{$t.bot-nick}: ” ~ ｢&infix:['+<'](1, 2)｣, 56 | /$link .+? ‘src/core.c/Int.pm6’/); 57 | 58 | $t.test(‘infix operator’, 59 | “{$t.bot-nick}: 1 < 2”, 60 | /$link .+? ‘src/core.c/Int.pm6’/); 61 | 62 | 63 | # Other revisions (not HEAD) 64 | 65 | $t.test(‘running on a provided revision’, 66 | “{$t.bot-nick}: 6c2f24455c NaN.FatRat.Bool()”, 67 | /^ ‘, https://github.com/rakudo/rakudo/blob/6c2f244/src/core/Rational.pm6#L77’ $/); 68 | 69 | 70 | # Errors 71 | 72 | $t.test(‘not a code-like thing’, 73 | “{$t.bot-nick}: ∞”, 74 | /^ ‘, No idea, boss. Can you give me a Code object?’ $/); 75 | 76 | $t.test(‘syntax error’, 77 | “{$t.bot-nick}: 2 +”, 78 | /^ ‘, No idea, boss. Can you give me a Code object? Output: ’ .* ‘===’ .* ‘SORRY!’ .* $/); 79 | 80 | 81 | # Proto vs actual method 82 | 83 | my $proto-line; 84 | $t.test(‘proto without parens’, 85 | “{$t.bot-nick}: 42.hash”, 86 | /$link .+? ‘src/core.c/Any.pm6#L’(\d+) {$proto-line=+~$0} $/); 87 | 88 | my $concrete-line; 89 | $t.test(‘concrete with parens’, 90 | “{$t.bot-nick}: 42.hash()”, 91 | /$link .+? ‘src/core.c/Any.pm6#L’(\d+) {$concrete-line=+~$0} $/); 92 | 93 | cmp-ok $proto-line, &[<], $concrete-line, ‘proto line is before the actual method’; 94 | 95 | 96 | # More complex cases 97 | 98 | $t.test(‘range with infix dot’, 99 | “{$t.bot-nick}: ^10 .reverse.skip(10).iterator()”, 100 | /$link .+? ‘src/core.c/Seq.pm6’/); 101 | 102 | $t.test(‘range with infix dot (no parens for method call)’, 103 | “{$t.bot-nick}: ^10 .reverse.skip(10).iterator”, 104 | /$link .+? ‘src/core.c/Seq.pm6’/); 105 | 106 | $t.test(‘atomic op’, 107 | “{$t.bot-nick}: ” ~ ｢&postfix:<⚛++>(my atomicint $x)｣, 108 | /$link .+? ‘src/core.c/atomicops.pm6’/); 109 | 110 | $t.test(‘skipping of undefined candidates’, 111 | “{$t.bot-nick}: ” ~ ｢/^/.ACCEPTS(any("opensuse", "linux"))｣, 112 | /$link .+? ‘src/core.c/Code.pm6’/); 113 | 114 | $t.test(‘large piece of code’, 115 | “{$t.bot-nick}: ” ~ ｢Seq.new(class :: does Iterator { has $!n = 10; method pull-one {say "pulling!"; $!n-- and 42 or IterationEnd }; method skip-one { $!n-- }; method count-only { 10 } }.new).tail()｣, 116 | /$link .+? ‘src/core.c/Any-iterable-methods.pm’/); 117 | 118 | $t.test(‘stderr warnings are ignored’, 119 | “{$t.bot-nick}: ” ~ ｢(my %b = :1a).ACCEPTS(my %a = :1a)｣, 120 | /$link .+? ‘src/core.c/Map.pm6’/); 121 | 122 | $t.last-test; 123 | done-testing; 124 | END $t.end; 125 | -------------------------------------------------------------------------------- /xbin/Shareable.p6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | # Copyright © 2018-2023 3 | # Aleks-Daniel Jakimenko-Aleksejev 4 | # 5 | # This program is free software: you can redistribute it and/or modify 6 | # it under the terms of the GNU Affero General Public License as published by 7 | # the Free Software Foundation, either version 3 of the License, or 8 | # (at your option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU Affero General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU Affero General Public License 16 | # along with this program. If not, see . 17 | 18 | use Whateverable; 19 | use Whateverable::Bits; 20 | use Whateverable::Builds; 21 | use Whateverable::Config; 22 | use Whateverable::Running; 23 | 24 | use Cro::HTTP::Router; 25 | use Cro::HTTP::Server; 26 | use IRC::Client; 27 | use JSON::Fast; 28 | 29 | #my $host-arch = $*KERNEL.hardware; 30 | my $host-arch = ‘x86_64’; 31 | $host-arch = ‘amd64’|‘x86_64’ if $host-arch eq ‘amd64’|‘x86_64’; 32 | #$host-arch = $*KERNEL.name ~ ‘-’ ~ $host-arch; 33 | $host-arch = ‘linux’ ~ ‘-’ ~ $host-arch; 34 | 35 | sub cached-archive($build where ‘HEAD.tar.gz’, :$backend=‘rakudo-moar’, :$arch) { 36 | my $repo = $CONFIG{$backend}; 37 | my $full-commit = to-full-commit ‘HEAD’, :$repo; # TODO that's slightly repetitive 38 | my $file = “/tmp/whateverable/shareable/$backend/$full-commit.tar.gz”.IO; 39 | if not $file.e { 40 | run-smth :$backend, $full-commit, sub ($build-path) { 41 | # can only be in this block once because 42 | # it locks on the build while it's used 43 | return if $file.e; 44 | mkdir $file.IO.parent; # for the first run 45 | .unlink for $file.IO.parent.dir; # TODO any way to be more selective? 46 | my $proc = run , $file, ‘--’, $build-path; 47 | # TODO what if it failed? Can it fail? 48 | # TODO Some race-ness is still not handled 49 | } 50 | } 51 | header ‘Content-Disposition’, “attachment; filename="{$file.IO.basename}"”; 52 | static ~$file 53 | } 54 | 55 | my $application = route { 56 | get sub () { redirect :temporary, ‘https://github.com/Raku/whateverable’ } 57 | get sub ($build, :$type=‘rakudo-moar’, :$arch) { 58 | return not-found if $arch and $arch ne $host-arch; 59 | my $backend = $type; # “backend” is used internally but sounds weird 60 | # TODO change once resolved: https://github.com/croservices/cro-http/issues/21 61 | return bad-request unless $backend ~~ .any; 62 | return cached-archive $build, :$backend, :$arch if $build eq ‘HEAD.tar.gz’; 63 | my $repo = $CONFIG{$backend}; 64 | my $full-commit = to-full-commit $build, :$repo; 65 | return not-found unless $full-commit; 66 | return not-found unless build-exists $full-commit, :$backend; 67 | 68 | my $archive-path = “$CONFIG{$backend}/$full-commit.tar.zst”; 69 | my $archive-link = “$CONFIG{$backend}/$full-commit”; 70 | 71 | my $file = $archive-path.IO.e ?? $archive-path !! $archive-link.IO.resolve.Str; 72 | 73 | # Expose full commit sha in headers. 74 | # This header will never be standardized, so I'm 75 | # including the X- prefix. 76 | # https://stackoverflow.com/questions/3561381/custom-http-headers-naming-conventions 77 | header ‘X-Full-Commit’, $full-commit; 78 | 79 | header ‘Content-Disposition’, “attachment; filename="{$file.IO.basename}"”; 80 | static $file 81 | } 82 | } 83 | 84 | ensure-config; 85 | my Cro::Service $share = Cro::HTTP::Server.new: :$application, 86 | :host($CONFIG), :port($CONFIG); 87 | $share.start; # TODO handle exceptions 88 | 89 | unit class Shareable does Whateverable; 90 | 91 | method help($msg) { 92 | “Like this: {$msg.server.current-nick}: f583f22” 93 | } 94 | 95 | multi method irc-to-me($msg where /^ $=[\S+] $/) { 96 | my $full-commit = to-full-commit ~$; 97 | return ‘No build for this commit’ unless build-exists $full-commit; 98 | my $link = $CONFIG // $CONFIG; 99 | “$link/$” 100 | } 101 | 102 | 103 | Shareable.new.selfrun: ‘shareable6’, [ fuzzy-nick(‘shareable6’, 2) ] 104 | 105 | # vim: expandtab shiftwidth=4 ft=perl6 106 | -------------------------------------------------------------------------------- /xbin/Notable.p6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | # Copyright © 2018-2023 3 | # Aleks-Daniel Jakimenko-Aleksejev 4 | # 5 | # This program is free software: you can redistribute it and/or modify 6 | # it under the terms of the GNU Affero General Public License as published by 7 | # the Free Software Foundation, either version 3 of the License, or 8 | # (at your option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU Affero General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU Affero General Public License 16 | # along with this program. If not, see . 17 | 18 | use Whateverable; 19 | use Whateverable::Bits; 20 | use Whateverable::FootgunDB; 21 | 22 | use IRC::Client; 23 | use JSON::Fast; 24 | 25 | unit class Notable does Whateverable; 26 | 27 | # TODO use FootgunDB here 28 | my $db = FootgunDB.new: name => ‘notable/notes’; 29 | END { $db.clean } 30 | my @shortcuts = ‘weekly’; # first shortcut here is the default topic 31 | 32 | method help($msg) { 33 | “Like this: {$msg.server.current-nick}: weekly rakudo is now 10x as fast” 34 | } 35 | method private-messages-allowed() { True } 36 | 37 | # XXX The logic here is a bit convoluted. It is meant to be a 38 | # zero-width match (only then things work), but I don't think this 39 | # was what I meant when I originaly wrote it. 40 | my regex shortcut($msg) { } 42 | my regex topic { <[\w:_-]>+ } 43 | 44 | #| List topics 45 | multi method irc-to-me($msg where ‘list’) { 46 | my @topics = $db.read.keys.sort; 47 | return ‘No notes yet’ unless @topics; 48 | @topics.join(‘ ’) but ProperStr(@topics.join: “\n”) 49 | } 50 | 51 | #| Get notes 52 | multi method irc-to-me($msg where 53 | { .Str ~~ m:r/^ \s* [ || ] \s* $/ }) { 54 | my $topic = ~($ // $.made); 55 | my $data = $db.read; 56 | return “No notes for “$topic”” if $data{$topic}:!exists; 57 | my @notes = $data{$topic}.map: { 58 | “$_ <$_>: $_” 59 | } 60 | ((“{s +@notes, ‘note’}: ” ~ @notes.join: ‘ ; ’) 61 | but ProperStr(@notes.join: “\n”)) 62 | but PrettyLink({“{s +@notes, ‘note’}: $_”}) 63 | } 64 | 65 | #| Clear notes 66 | multi method irc-to-me($msg where 67 | { .Str ~~ m:r/^ 68 | :my @commands = ; 69 | [ 70 | || \s* @commands \s* 71 | || \s* @commands \s+ \s* 72 | || \s* \s+ @commands \s* 73 | ] 74 | $/ }) { 75 | my $topic = ~($ // $.made); 76 | my $data = $db.read; 77 | return “No notes for “$topic”” if $data{$topic}:!exists; 78 | my $suffix = ~timestampish; 79 | my $new-topic = $topic ~ ‘_’ ~ $suffix; 80 | $data{$new-topic} = $data{$topic}; 81 | $data{$topic}:delete; 82 | $db.write: $data; 83 | “Moved existing notes to “$new-topic”” 84 | } 85 | 86 | #| Add new topic 87 | multi method irc-to-me($msg where 88 | { .Str ~~ m:r/^ \s* [ ‘new-topic’ | ‘new-category’ ] \s+ \s* $/ }) { 89 | my $topic = ~$; 90 | my $data = $db.read; 91 | return “Topic “$topic” already exists” if $data{$topic}:exists; 92 | $data{$topic} = []; 93 | $db.write: $data; 94 | “New topic added (“$topic”)” 95 | } 96 | 97 | #| Add a note 98 | multi method irc-to-me($msg where 99 | { .Str ~~ m:r/^ \s* [ || \s+] $=[.*] $/ }) { 100 | my $topic = $; 101 | my $stuff = ~$; 102 | my $data = $db.read; 103 | if $topic.defined and $data{~$topic}:!exists { 104 | # someone forgot to specify a topic, just default to the first shortcut 105 | $topic = @shortcuts.head; 106 | $stuff = $msg; 107 | } 108 | $topic //= $.made; 109 | $data{~$topic}.push: %( 110 | text => ~$stuff, 111 | timestamp => timestampish, 112 | nick => $msg.nick, 113 | ); 114 | $db.write: $data; 115 | “Noted! ($topic)” 116 | } 117 | 118 | 119 | Notable.new.selfrun: ‘notable6’, [ / [@shortcuts]6? /, 120 | fuzzy-nick(‘notable6’, 1) ] 121 | 122 | # vim: expandtab shiftwidth=4 ft=perl6 123 | -------------------------------------------------------------------------------- /xbin/Buildable.p6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | # Copyright © 2017-2023 3 | # Aleks-Daniel Jakimenko-Aleksejev 4 | # Copyright © 2016 5 | # Daniel Green 6 | # 7 | # This program is free software: you can redistribute it and/or modify 8 | # it under the terms of the GNU Affero General Public License as published by 9 | # the Free Software Foundation, either version 3 of the License, or 10 | # (at your option) any later version. 11 | # 12 | # This program is distributed in the hope that it will be useful, 13 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | # GNU Affero General Public License for more details. 16 | # 17 | # You should have received a copy of the GNU Affero General Public License 18 | # along with this program. If not, see . 19 | 20 | use Whateverable; 21 | use Whateverable::Bits; 22 | use Whateverable::Building; 23 | use Whateverable::Config; 24 | 25 | use IRC::Client; 26 | 27 | unit class Buildable does Whateverable; 28 | 29 | method help($msg) { 30 | “Like this: {$msg.server.current-nick}: info” 31 | } 32 | 33 | my $meta-lock = Lock.new; 34 | my $building = Promise.kept; 35 | my $packing = Promise.kept; 36 | 37 | my $trigger-supplier = Supplier.new; 38 | my $trigger-supply = $trigger-supplier.Supply; 39 | 40 | sub get-projects() { 41 | $CONFIG.keys.sort.reverse # XXX .reverse to make rakudo-moar first 42 | } 43 | 44 | multi method irc-to-me($msg where /:i [status|info|builds|stats?]/) { 45 | my $projects = get-projects.map({ 46 | my $total-size = 0; 47 | my $files = 0; 48 | my $builds = 0; 49 | for dir $CONFIG{$_} { 50 | $total-size += .s unless .l; 51 | $files++ unless .l; 52 | $builds++ if .l or .ends-with: '.tar.zst'; 53 | } 54 | “$builds $_ builds in $files archives ({round $total-size ÷ 10⁹, 0.1} GB)” 55 | }).join: ‘; ’; 56 | 57 | my $activity = ‘’; 58 | $meta-lock.protect: { 59 | if $building.status == Planned { 60 | $activity ~= ‘(⏳ Building…) ’; 61 | $building.then: { $msg.reply: ‘Done building!’ }; 62 | } 63 | if $packing.status == Planned { 64 | $activity ~= ‘(📦 Packing…) ’; 65 | $packing.then: { $msg.reply: ‘Done packing!’ }; 66 | } 67 | } 68 | $activity ||= ‘(😴 Idle) ’; 69 | 70 | $trigger-supplier.emit(True); # trigger based on IRC message, just in case 71 | 72 | $activity ~ $projects 73 | } 74 | 75 | ensure-config; 76 | use Cro::HTTP::Router; 77 | use Cro::HTTP::Server; 78 | my $application = route { 79 | get -> { $trigger-supplier.emit(True); content 'text/html', 'OK' } 80 | post -> { $trigger-supplier.emit(True); content 'text/html', 'OK' } 81 | } 82 | my Cro::Service $service = Cro::HTTP::Server.new: 83 | :host($CONFIG), :port($CONFIG), :$application; 84 | $service.start; 85 | 86 | 87 | multi method keep-building($msg) { 88 | my $bleed = Supplier.new; 89 | react { 90 | whenever $bleed {} # do nothing, just ignore values that are bled 91 | whenever Supply.interval: 60 × 30 { 92 | $trigger-supplier.emit(True); 93 | } 94 | whenever $trigger-supply.throttle: 1, ({ 95 | await $meta-lock.protect: { $building }; 96 | # XXX Ideally this should use :vent-at(0), but that is a magical 97 | # value in Rakudo. So, for now, it does one extra `git pull` 98 | # after repeated webhooks, but that's not bad (just unnecessary). 99 | # https://github.com/rakudo/rakudo/issues/5358 100 | }), :vent-at(1), :bleed($bleed) { 101 | $meta-lock.protect: { 102 | $building = start { build-all-commits $_ for get-projects() }; 103 | whenever $building {} 104 | } 105 | } 106 | whenever Supply.interval: 60 × 60 { 107 | $meta-lock.protect: { 108 | leave if $packing.status == Planned; 109 | $packing = start { pack-all-builds $_ for get-projects() }; 110 | whenever $packing {} 111 | }; 112 | } 113 | } 114 | 115 | CATCH { default { 116 | note $_; 117 | start { sleep 20; exit }; # restart itself 118 | self.handle-exception: $_, $msg 119 | } } 120 | } 121 | 122 | multi method irc-connected($msg) { 123 | once start self.keep-building: $msg 124 | } 125 | 126 | 127 | Buildable.new.selfrun: ‘buildable6’, [ / build[s]?6? /, 128 | fuzzy-nick(‘buildable6’, 2) ] 129 | 130 | # vim: expandtab shiftwidth=4 ft=perl6 131 | -------------------------------------------------------------------------------- /lib/Whateverable/Messages.pm6: -------------------------------------------------------------------------------- 1 | # Copyright © 2016-2023 2 | # Aleks-Daniel Jakimenko-Aleksejev 3 | # Copyright © 2016 4 | # Daniel Green 5 | # 6 | # This program is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU Affero General Public License as published by 8 | # the Free Software Foundation, either version 3 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # This program is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU Affero General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU Affero General Public License 17 | # along with this program. If not, see . 18 | 19 | use IRC::Client; 20 | use Whateverable::Bits; 21 | use Whateverable::Config; 22 | 23 | unit module Whateverable::Messages; 24 | 25 | role Enough is export { } #← Used to prevent recursion in exception handling 26 | 27 | sub handle-exception($exception, $msg?) is export { 28 | CATCH { # exception handling is too fat, so let's do this also… 29 | .note; 30 | return ‘Exception was thrown while I was trying to handle another exception…’ 31 | ~ ‘ What are they gonna do to me, Sarge? What are they gonna do⁈’ 32 | } 33 | if $exception ~~ Whateverable::X::HandleableAdHoc { # oh, it's OK! 34 | return $exception.message but Reply($_) with $msg; 35 | return $exception.message 36 | } 37 | 38 | note $exception; 39 | given $msg { 40 | # TODO handle other types 41 | when IRC::Client::Message::Privmsg::Channel { 42 | .irc.send-cmd: ‘PRIVMSG’, $CONFIG, “I have a bug! See {.channel}. Help me!”, 43 | :server(.server), :prefix($CONFIG.join(‘, ’) ~ ‘: ’) 44 | if .channel ne $CONFIG 45 | } 46 | default { 47 | .irc.send-cmd: ‘PRIVMSG’, $CONFIG, ‘Unhandled exception somewhere!’, 48 | :server(.server), :prefix($CONFIG.join(‘, ’) ~ ‘: ’); 49 | } 50 | } 51 | 52 | my ($text, @files) = flat awesomify-exception $exception; 53 | @files .= map({ ‘uncommitted-’ ~ .split(‘/’).tail => .IO.slurp }); 54 | # TODO disabled because it was causing 422 Unprocessable Entity error (I don't know why) 55 | # Either way it's probably irrelevant because bots tend to run with clean repo state now. 56 | # @files.push: ‘|git-diff-HEAD.patch’ => run(:out, ).out.slurp-rest if @files; 57 | @files.push: ‘result.md’ => $text; 58 | 59 | my $return = (‘’ but FileStore(%@files)) 60 | but PrettyLink({“and I oop! Backtrace: $_”}); 61 | 62 | # previously: “No! It wasn't me! It was the one-armed man!” https://youtu.be/MC6bzR9qmxM?t=97 63 | $return = $return but Reply($_) with $msg; 64 | if $msg !~~ IRC::Client::Message::Privmsg::Channel { 65 | $msg.irc.send-cmd: ‘PRIVMSG’, $CONFIG, $return but Enough, 66 | :server($msg.server), 67 | :prefix($CONFIG.join(‘, ’) ~ ‘: ’); 68 | return 69 | } 70 | $return 71 | } 72 | 73 | sub awesomify-exception($exception) { 74 | my @local-files; 75 | my $sha = run(:out, ).out.slurp-rest; 76 | ‘
’ ~
 77 |     $exception.gist.lines.map({
 78 |         # TODO Proper way to get data out of exceptions?
 79 |         # For example, right now it is broken for paths with spaces
 80 |         when /:s ^([\s**2|\s**6]in \w+ \S* at “./”?)$=[\S+](
 81 |                                          [<.ws>‘(’<-[)]>+‘)’]? line )$=[\d+]$/ {
 82 |             my $status = run :out, ,
 83 |                                    ~$;
 84 |             proceed if !$status && !%*ENV; # not a repo file and not in the debug mode
 85 |             my $private-debugging = !$status;
 86 |             $status = $status.out.slurp-rest;
 87 |             my $uncommitted = $status && !$status.starts-with: ‘  ’; # not committed yet
 88 |             @local-files.push: ~$ if $uncommitted || $private-debugging;
 89 |             my $href = $uncommitted || $private-debugging
 90 |               ?? “#file-uncommitted-{$.split(‘/’).tail.lc.trans(‘.’ => ‘-’)}-” # TODO not perfect but good enough
 91 |               !! “$CONFIG/blob/$sha/{markdown-escape $}#”;
 92 |             $href ~= “L$”;
 93 | 
 94 |             markdown-escape($0) ~
 95 |             # let's hope for the best ↓
 96 |             “{$}” ~
 97 |             markdown-escape($1 ~ $) ~
 98 |             ($uncommitted ?? ‘ (⚠ uncommitted)’ !! ‘’)
 99 |         }
100 |         default { $_ }
101 |     }).join(“\n”)
102 |     ~ ‘
’, @local-files 103 | } 104 | 105 | # vim: expandtab shiftwidth=4 ft=perl6 106 | -------------------------------------------------------------------------------- /xbin/Evalable.p6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | # Copyright © 2016-2023 3 | # Aleks-Daniel Jakimenko-Aleksejev 4 | # Copyright © 2016 5 | # Daniel Green 6 | # 7 | # This program is free software: you can redistribute it and/or modify 8 | # it under the terms of the GNU Affero General Public License as published by 9 | # the Free Software Foundation, either version 3 of the License, or 10 | # (at your option) any later version. 11 | # 12 | # This program is distributed in the hope that it will be useful, 13 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | # GNU Affero General Public License for more details. 16 | # 17 | # You should have received a copy of the GNU Affero General Public License 18 | # along with this program. If not, see . 19 | 20 | use Whateverable; 21 | use Whateverable::Bits; 22 | use Whateverable::Builds; 23 | use Whateverable::Config; 24 | use Whateverable::Discordable; 25 | use Whateverable::Processing; 26 | use Whateverable::Running; 27 | use Whateverable::Userlist; 28 | 29 | use IRC::Client; 30 | use Terminal::ANSIColor; 31 | 32 | unit class Evalable does Whateverable does Whateverable::Userlist; 33 | 34 | method help($msg) { 35 | “Like this: {$msg.server.current-nick}: say ‘hello’; say ‘world’” 36 | } 37 | 38 | multi method irc-to-me($msg) { 39 | # Do not answer when camelia is around (she reacts to the same triggers). 40 | # But always do when the message is from discord because camelia doesn't 41 | # support that. 42 | return self.process: $msg, $msg.text if $msg.nick ~~ FromDiscord or 43 | $msg.args[1] !~~ /^ \s*[master|rakudo|r|‘r-m’|m|p6|perl6]‘:’\s /; 44 | self.make-believe: $msg, (‘camelia’,), { 45 | self.process: $msg, $msg.text 46 | } 47 | } 48 | 49 | #↓ Detect if somebody accidentally forgot “m:” or other command prefix 50 | multi method irc-privmsg-channel($msg) { 51 | my $nonword-ratio = $msg.args[1].comb(/<-alpha -space>/) ÷ $msg.args[1].chars; 52 | nextsame if $nonword-ratio < 0.1; # skip if doesn't look like code at all 53 | nextsame if $msg.args[1] ~~ /^ \s*<[\w-]>+‘:’ /; # skip messages to other bots 54 | nextsame if $msg.args[1] eq ‘???’; # unfortunate trigger (???) 55 | nextsame if $msg.args[1] ~~ /^ \w+ \s+ ‘&’ \s* $/; # unfortunate trigger (sleep &) 56 | 57 | self.process: $msg, $msg.args[1], :good-only 58 | } 59 | 60 | method process($msg, $code, :$good-only?) { 61 | my $commit = %*BOT-ENV; 62 | my $file = process-code $code, $msg; 63 | LEAVE .unlink with $file; 64 | 65 | # convert to real id so we can look up the build 66 | my $full-commit = to-full-commit $commit; 67 | my $short-commit = to-full-commit $commit, :short; 68 | 69 | if not build-exists $full-commit { 70 | return if $good-only; 71 | grumble “No build for $short-commit. Not sure how this happened!” 72 | } 73 | 74 | # actually run the code 75 | my $result = run-snippet $full-commit, $file; 76 | my $output = $result; 77 | if $good-only and ($result ≤ 0 or $result == SIGHUP) { 78 | # forcefully proceed ↑ with non-zero signals (except sighupped timeouts) 79 | return if $result ≠ 0; 80 | return if $result ≠ 0; 81 | return if !$output; 82 | return if $output ~~ /^‘WARNINGS for ’\N*\n‘Useless use’/; 83 | return if $output ~~ /^‘Potential difficulties:’/; 84 | return if $output ~~ /^‘Use of uninitialized value of type Any in string context.’/; 85 | } 86 | my $extra = ‘’; 87 | if $result < 0 { # numbers less than zero indicate other weird failures 88 | $output = “Cannot test $full-commit ($output)” 89 | } else { 90 | $extra ~= “(exit code $result) ” if $result ≠ 0; 91 | $extra ~= “(signal {Signal($result)}) ” if $result ≠ 0 92 | } 93 | 94 | my $reply-start = “rakudo-moar $short-commit: OUTPUT: «$extra”; 95 | my $reply-end = ‘»’; 96 | if $CONFIG ≥ ($reply-start, $output, $reply-end).map(*.encode.elems).sum { 97 | return $reply-start ~ $output ~ $reply-end # no gist 98 | } 99 | $reply-end = ‘…’ ~ $reply-end; 100 | my $extra-size = ($reply-start, $reply-end).map(*.encode.elems).sum; 101 | my $output-size = 0; 102 | my $SHORT-MESSAGE-LIMIT = $CONFIG × ⅓; 103 | my $output-cut = $output.comb.grep({ 104 | $output-size += .encode.elems; 105 | $output-size + $extra-size < $SHORT-MESSAGE-LIMIT 106 | })[0..*-2].join; 107 | reply $msg, $reply-start ~ $output-cut ~ $reply-end; 108 | sleep 0.02; 109 | my $gist = ($extra ?? “$extra\n” !! ‘’) ~ colorstrip $output; 110 | (‘’ but ProperStr($gist)) but PrettyLink({ “Full output: $_” }) 111 | } 112 | 113 | 114 | %*BOT-ENV = ‘HEAD’; 115 | 116 | Evalable.new.selfrun: ‘evalable6’, [/ [ | \s*[master|rakudo|‘r-m’|m|p6|perl6|raku] 117 | | e[val]?6? | what ] /, 118 | fuzzy-nick(‘evalable6’, 1) ] 119 | 120 | # vim: expandtab shiftwidth=4 ft=perl6 121 | -------------------------------------------------------------------------------- /xbin/Greppable.p6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | # Copyright © 2016-2023 3 | # Aleks-Daniel Jakimenko-Aleksejev 4 | # Copyright © 2016 5 | # Daniel Green 6 | # 7 | # This program is free software: you can redistribute it and/or modify 8 | # it under the terms of the GNU Affero General Public License as published by 9 | # the Free Software Foundation, either version 3 of the License, or 10 | # (at your option) any later version. 11 | # 12 | # This program is distributed in the hope that it will be useful, 13 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | # GNU Affero General Public License for more details. 16 | # 17 | # You should have received a copy of the GNU Affero General Public License 18 | # along with this program. If not, see . 19 | 20 | use Whateverable; 21 | use Whateverable::Bits; 22 | use Whateverable::Output; 23 | use Whateverable::Running; 24 | 25 | use Config::INI; 26 | use IRC::Client; 27 | 28 | unit class Greppable does Whateverable; 29 | 30 | my $ECO-PATH = ‘data/all-modules’; 31 | my $ECO-ORIGIN = ‘https://github.com/moritz/perl6-all-modules’; 32 | 33 | method help($msg) { 34 | “Like this: {$msg.server.current-nick}: password” 35 | } 36 | 37 | sub process-ls-line($line) { 38 | # TODO markdownify 39 | $line 40 | } 41 | sub process-grep-line($line, %commits) { # 🙈 42 | my $backticks = ｢`｣ x (($line.comb(/｢`｣+/) || ｢｣).max.chars + 1); 43 | my ($path, $line-number, $text) = $line.split: “\x0”, 3; 44 | 45 | return Empty if $path.ends-with: ‘.pdf’; # somehow pdf files are not considered binary 46 | 47 | my $start = “perl6-all-modules/$path”; # Not a module, unless… 48 | if $path ~~ /^ $=[<-[/]>+] ‘/’ $=[ <-[/]>+ ‘/’ <-[/]>+ ] 49 | ‘/’ $=.* $/ { 50 | my $source = $; 51 | my $repo = $; 52 | my $long-path = $; 53 | my $commit = %commits{“$source/$repo”}; 54 | 55 | without $commit { # cache it! 56 | $commit = do given $source { 57 | my $dotgitrepo = “$ECO-PATH/$source/$repo/.gitrepo”.IO; 58 | when ‘github’ 59 | | ‘gitlab’ { Config::INI::parse(slurp $dotgitrepo) } 60 | when ‘cpan’ { run(:out, :cwd($ECO-PATH), 61 | ).out.slurp.trim } 62 | default { die “Unsupported source “$source”” } 63 | } 64 | %commits{$repo} = $commit; 65 | } 66 | my $link = do given $source { 67 | when ‘github’ 68 | | ‘gitlab’ { “https://$source.com/$repo/blob/$commit/$long-path#L$line-number” } 69 | when ‘cpan’ { “$ECO-ORIGIN/blob/$commit/$source/$repo/$long-path#L$line-number” } 70 | default { die “Unsupported source “$source”” } # already handled anyway 71 | } 72 | my $short-path = $long-path.subst: /^ .*‘/’ /, ‘’; 73 | $short-path = “…/$short-path”;# if $long-path ne $short-path; 74 | $start = “[{$repo}
``{$short-path}`` :*$line-number*:]($link)”; 75 | 76 | take ~$repo # used for stats in PrettyLink 77 | } 78 | $text = shorten $text || ‘’, 300; # do not print too long lines 79 | $text = markdown-escape $text; 80 | $text ~~ s:g/ “\c[ESC][1;31m” (.*?) [ “\c[ESC][m” | $ ] /{$0}<\/b>/; # TODO get rid of \/ ? 81 | 82 | “| $start | {$text} |” 83 | } 84 | 85 | multi method irc-to-me($msg where .args[1].starts-with(‘file’ | ‘tree’) && 86 | /^ \s* [ || ‘/’ $=[.*] ‘/’ 87 | || $=[.*?] ] \s* $/) { 88 | my $result = run :out, :cwd($ECO-PATH), ; 89 | my $out = perl6-grep $result.out, $; 90 | my $gist = $out.map({ process-ls-line $_ }).join(“\n”); 91 | return ‘Found nothing!’ unless $gist; 92 | ‘’ but ProperStr($gist) 93 | } 94 | 95 | multi method irc-to-me($msg) { 96 | my @cmd = |, $msg; 98 | 99 | run :out(Nil), :cwd($ECO-PATH), ; 100 | my $result = get-output :cwd($ECO-PATH), |@cmd; 101 | 102 | grumble ‘Sorry, can't do that’ if $result ≠ 0 | 1 or $result ≠ 0; 103 | grumble ‘Found nothing!’ unless $result; 104 | 105 | my %commits = (); 106 | my $gist = “| File | Code |\n|--|--|\n”; 107 | my $stats = gather { 108 | $gist ~= $result.split(/“\n”|“\r\n”/).map({process-grep-line $_, %commits}).join: “\n”; 109 | # 🙈 after touching the .split part three times, I think this should work… 110 | # 🙈 it will eat \r but that's not too bad 111 | } 112 | my $total = $stats.elems; 113 | my $modules = $stats.Set.elems; 114 | (‘’ but FileStore({ ‘result.md’ => $gist })) 115 | but PrettyLink({“{s $total, ‘line’}, {s $modules, ‘module’}: $_”}) 116 | } 117 | 118 | 119 | if $ECO-PATH.IO !~~ :d { 120 | run , $ECO-ORIGIN, $ECO-PATH 121 | } 122 | 123 | Greppable.new.selfrun: ‘greppable6’, [ / [file|tree]? grep6? /, 124 | fuzzy-nick(‘greppable6’, 2) ] 125 | 126 | # vim: expandtab shiftwidth=4 ft=perl6 127 | -------------------------------------------------------------------------------- /xbin/Bloatable.p6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | # Copyright © 2016-2023 3 | # Aleks-Daniel Jakimenko-Aleksejev 4 | # Copyright © 2016 5 | # Daniel Green 6 | # 7 | # This program is free software: you can redistribute it and/or modify 8 | # it under the terms of the GNU Affero General Public License as published by 9 | # the Free Software Foundation, either version 3 of the License, or 10 | # (at your option) any later version. 11 | # 12 | # This program is distributed in the hope that it will be useful, 13 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | # GNU Affero General Public License for more details. 16 | # 17 | # You should have received a copy of the GNU Affero General Public License 18 | # along with this program. If not, see . 19 | 20 | use Whateverable; 21 | use Whateverable::Bits; 22 | use Whateverable::Builds; 23 | use Whateverable::Config; 24 | use Whateverable::Output; 25 | use Whateverable::Running; 26 | 27 | use IRC::Client; 28 | 29 | unit class Bloatable does Whateverable; 30 | 31 | method help($msg) { 32 | “Like this: {$msg.server.current-nick}: d=compileunits 292dc6a,HEAD” 33 | } 34 | 35 | multi method irc-to-me($msg where /^ :r [ [ ‘d=’ | ‘-d’ \s* ] $=[\S+] \s ]? 36 | \s* $=<.&commit-list> $/) { 37 | self.process: $msg, ~$, ~($ // ‘compileunits’) 38 | } 39 | 40 | multi method bloaty($sources, %prev, %cur) { 41 | run-smth :backend, %prev, -> $prev-path { 42 | !“$prev-path/lib/libmoar.so”.IO.e 43 | ?? “No libmoar.so file in build %prev” 44 | !! run-smth :backend, %cur, -> $cur-path { 45 | !“$cur-path/lib/libmoar.so”.IO.e 46 | ?? “No libmoar.so file in build %cur” 47 | !! get-output ‘bloaty’, ‘-d’, $sources, ‘-n’, ‘50’, 48 | “$cur-path/lib/libmoar.so”, ‘--’, “$prev-path/lib/libmoar.so” 49 | } 50 | } 51 | } 52 | 53 | multi method bloaty($sources, %prev) { 54 | run-smth :backend, %prev, -> $prev-path { 55 | !“$prev-path/lib/libmoar.so”.IO.e 56 | ?? “No libmoar.so file in build %prev” 57 | !! get-output ‘bloaty’, ‘-d’, $sources, ‘-n’, ‘100’, 58 | “$prev-path/lib/libmoar.so” 59 | } 60 | } 61 | 62 | method did-you-mean($out) { 63 | return if $out !~~ Associative; 64 | return if $out == 0; 65 | return unless $out ~~ /(‘no such data source:’ .*)/; 66 | $0.tc ~ ‘ (Did you mean one of these: ’ 67 | ~ get-output(‘bloaty’, ‘--list-sources’ 68 | ).lines.map(*.words[0]).join(‘ ’) 69 | ~ ‘ ?)’ 70 | } 71 | 72 | method process($msg, $config, $sources is copy) { 73 | my @commits = get-commits $config, repo => $CONFIG; 74 | my %files; 75 | my @processed; 76 | for @commits -> $commit { 77 | my %prev = @processed.tail if @processed; 78 | my %cur; 79 | # convert to real ids so we can look up the builds 80 | %cur = to-full-commit $commit, repo => $CONFIG; 81 | if not defined %cur { 82 | %cur = “Cannot find revision $commit”; 83 | my @options = ; 84 | %cur ~= “ (did you mean “{get-short-commit get-similar $commit, @options, repo => $CONFIG}”?)” 85 | } elsif not build-exists %cur, :backend { 86 | %cur = ‘No build for this commit’ 87 | } 88 | %cur = get-short-commit $commit; 89 | %cur ~= “({get-short-commit %cur})” if $commit eq ‘HEAD’; 90 | if %prev { 91 | my $filename = “result-{(1 + %files).fmt: ‘%05d’}”; 92 | my $result = “Comparing %prev → %cur\n”; 93 | if %prev { 94 | $result ~= “Skipping because of the error with %prev:\n”; 95 | $result ~= %prev 96 | } elsif %cur { 97 | $result ~= “Skipping because of the error with %cur:\n”; 98 | $result ~= %cur 99 | } elsif %prev eq %cur { 100 | $result ~= “Skipping because diffing the same commit is pointless.”; 101 | } else { 102 | my $out = self.bloaty: $sources, %prev, %cur; 103 | grumble $_ with self.did-you-mean: $out; 104 | $result ~= $out // $out; 105 | } 106 | %files{$filename} = $result 107 | } 108 | @processed.push: %cur 109 | } 110 | 111 | if @commits == 1 { 112 | my %prev = @processed.tail; 113 | return %prev if %prev; 114 | my $out = self.bloaty: $sources, %prev; 115 | return $_ with self.did-you-mean: $out; 116 | return ($out // $out) but ProperStr(“%prev\n{$out // $out}”) 117 | } elsif @commits == 2 and (@processed[*-2] or @processed[*-1]) { 118 | # print obvious problems without gisting the whole thing 119 | return @processed[*-2] || @processed[*-1]; 120 | # TODO this does not catch missing libmoar.so files 121 | } 122 | ‘’ but FileStore(%files); 123 | } 124 | 125 | 126 | Bloatable.new.selfrun: ‘bloatable6’, [ / bloat[y]?6? /, 127 | fuzzy-nick(‘bloatable6’, 2) ] 128 | 129 | # vim: expandtab shiftwidth=4 ft=perl6 130 | -------------------------------------------------------------------------------- /xt/releasable.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | BEGIN %*ENV = 1; 3 | %*ENV = ‘rakudo-mock’; 4 | 5 | use lib ; 6 | use File::Directory::Tree; 7 | use IRC::Client; 8 | use Test; 9 | use Testable; 10 | 11 | my $t = Testable.new: bot => ‘Releasable’; 12 | 13 | $t.common-tests: help => “status | status link”; 14 | 15 | $t.shortcut-tests: , 16 | ; 17 | 18 | # The idea is to generate a pseudorealistic repo that 19 | # is good enough for testing purposes. 20 | 21 | my $mock = ‘t/data/rakudo’.IO; 22 | rmtree $mock if $mock.e; 23 | mkdir $mock; 24 | run :cwd($mock), :out(Nil), ‘git’, ‘init’; 25 | mkdir $mock.add: ‘docs’; 26 | spurt $mock.add(‘docs/ChangeLog’), “New in 2090.07:\n + Additions:\n\n”; 27 | 28 | my @releases = ( 29 | ‘2090-08-19 Rakudo #990 (AlexDaniel)’, 30 | ‘2090-09-16 Rakudo #991’, 31 | ‘2090-10-21 Rakudo #992’, 32 | ‘2090-11-18 Rakudo #993’, 33 | ); 34 | 35 | sub changelog(Block $do) { 36 | my $path = $mock.add: ‘docs/ChangeLog’; 37 | spurt $path, $do(slurp $path); 38 | } 39 | 40 | sub tag-last($tag-name, $new-section = “New in {$tag-name + 0.01}” #← hahaha 41 | ~ “:\n + Additions:\n\n” ) { 42 | my $sha = run(:cwd($mock), :out, ‘git’, ‘rev-parse’, ‘HEAD’) 43 | .out.slurp-rest.chomp; 44 | run :cwd($mock), ‘git’, ‘tag’, ‘--annotate’, 45 | “--message=Blah $tag-name”, $tag-name; 46 | spurt $mock.add(‘VERSION’), $tag-name; 47 | changelog { $new-section ~ $_ } if defined $new-section 48 | } 49 | 50 | sub commit($message, :$log = True) { 51 | my $foo = ^9⁹ .pick; 52 | spurt $mock.add($foo), $foo; 53 | run :cwd($mock), ‘git’, ‘add’, ‘--’, $foo; 54 | run :cwd($mock), :out(Nil), ‘git’, ‘commit’, “--message=$message”; 55 | 56 | my $release-guide = “=head2 Planned future releases\n\n… … …\n\n” 57 | ~ @releases.map({ “ $_\n” }).join; 58 | spurt $mock.add(‘docs/release_guide.pod’), $release-guide; 59 | 60 | my $sha = run(:cwd($mock), :out, ‘git’, ‘rev-parse’, ‘HEAD’) 61 | .out.slurp-rest.chomp.substr: 0, 8; 62 | my $log-entry = $log ~~ Bool ?? “ + $message [$sha]\n” !! $log; 63 | changelog -> $file is copy { 64 | die without $file ~~ s//$log-entry/; 65 | $file 66 | } if $log; 67 | $sha 68 | } 69 | 70 | # TODO the number of blockers and the time left is not controllable 71 | 72 | # Basics 73 | 74 | commit ‘$!.pending (RT #68320)’; 75 | 76 | my $link = ｢https://github.com/rakudo/rakudo/issues?q=is:issue+is:open+label:%22%E2%9A%A0+blocker+%E2%9A%A0%22｣; 77 | $t.test(‘unknown format’, 78 | “{$t.bot-nick}: when?”, 79 | /^ ‘, Next release in ’\d+‘ day’s?‘ and ≈’\d+‘ hour’s?‘. ’ 80 | [ \d+‘ blocker’s? | ‘No blockers’ | “Blockers: $link” ]‘. ’ 81 | ‘Unknown changelog format’ $/); 82 | #“{$t.our-nick}, Details: https://whatever.able/fakeupload”); 83 | 84 | 85 | tag-last ‘2090.07’; 86 | commit ‘.hyper and .race finally re-added’; 87 | tag-last ‘2090.08’, Nil; 88 | my $to-be-logged = commit ‘A change that should be logged’, :!log; 89 | 90 | $t.test(‘not started yet’, 91 | “{$t.bot-nick}: status”, 92 | “{$t.our-nick}, Release date for Rakudo 2090.08 is listed in” 93 | ~ “ “Planned future releases”, but it was already released.”, 94 | /^ ‘, Next release in ’\d+‘ day’s?‘ and ≈’\d+‘ hour’s?‘. ’ 95 | [ \d+‘ blocker’s? | ‘No blockers’ | “Blockers: $link” ]‘. ’ 96 | ‘Changelog for this release was not started yet’ $/, 97 | “{$t.our-nick}, Details: https://whatever.able/fakeupload”); 98 | 99 | $t.test-gist(‘commits are listed even without a new section’, 100 | %(‘unreviewed.md’ => / $to-be-logged /) ); 101 | 102 | @releases.shift; 103 | 104 | my $to-be-logged-not = commit ‘A change that should not be logged’, :!log; 105 | my @real = ‘Furious whitespace changes’ xx 4; 106 | @real.push: ‘Fix nothing’; 107 | @real .= map: { commit $_, :!log }; 108 | my $log-entries = qq:to/END/; 109 | New in 2090.09: 110 | + Deprecations: 111 | + Deprecate everything [de1e7ea1] 112 | + Fixes: 113 | + Fix nothing [@real[*-1]] 114 | + Furious whitespace changes [@real[0]] [@real[1]] [@real[2]] 115 | [@real[3]] [abcabcabcabc] 116 | + No really, this change is very important [@real[1]] 117 | 118 | END 119 | changelog { $log-entries ~ $_ }; 120 | 121 | run :cwd($mock), ‘git’, ‘add’, ‘--’, ‘docs/ChangeLog’; 122 | commit “Changelog\n\nIntentionally not logged: $to-be-logged-not”, :!log; 123 | 124 | $t.test(‘realistic output’, 125 | “{$t.bot-nick}: release”, 126 | “{$t.our-nick}, Release manager is not specified yet.”, 127 | /^ ‘, Next release in ’\d+‘ day’s?‘ and ≈’\d+‘ hour’s?‘. ’ 128 | [ \d+‘ blocker’s? | ‘No blockers’ | “Blockers: $link” ]‘. ’ 129 | ‘6 out of 8 commits logged (⚠ 2 warnings)’ $/, # TODO ideally should be 7 out of 8 130 | “{$t.our-nick}, Details: https://whatever.able/fakeupload”); 131 | 132 | $t.test-gist(‘gisted files look alright’, 133 | %(‘!warnings!’ => 134 | ‘de1e7ea1 was referenced but there is no commit with this id’ 135 | ~ “\n” ~ ‘abcabcabcabc should be 8 characters in length’, 136 | ‘unreviewed.md’ => 137 | /｢
    + A change that should be logged｣
138 |                   ｢ [｣ $to-be-logged ｢]｣.*｢
｣ # TODO .* 140 | /, 141 | ) 142 | ); 143 | 144 | 145 | $t.test(‘uncommitted changed from a link’, 146 | “{$t.bot-nick}: changelog https://gist.github.com/AlexDaniel/45b98a8bd5935a53a3ed4762ea5f5d43/raw/”, 147 | “{$t.our-nick}, Successfully fetched the code from the provided URL”, 148 | “{$t.our-nick}, 1 out of 8 commits logged”, 149 | “{$t.our-nick}, Details: https://whatever.able/fakeupload”); 150 | 151 | # $t.last-test; # Deliberately no $t.last-test! (we can't repeat the first test) 152 | $t.test(‘No uncaught messages’, 153 | “{$t.bot-nick}: help”, 154 | /^ ‘, status | status link’ /); 155 | 156 | done-testing; 157 | END $t.end; 158 | 159 | # vim: expandtab shiftwidth=4 ft=perl6 160 | -------------------------------------------------------------------------------- /xbin/Coverable.p6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | # Copyright © 2016-2023 3 | # Daniel Green 4 | # Aleks-Daniel Jakimenko-Aleksejev 5 | # 6 | # This program is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU Affero General Public License as published by 8 | # the Free Software Foundation, either version 3 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # This program is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU Affero General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU Affero General Public License 17 | # along with this program. If not, see . 18 | 19 | use Whateverable; 20 | use Whateverable::Bits; 21 | use Whateverable::Builds; 22 | use Whateverable::Config; 23 | use Whateverable::Processing; 24 | use Whateverable::Running; 25 | 26 | use IRC::Client; 27 | 28 | unit class Coverable does Whateverable; 29 | 30 | constant TOTAL-TIME = 60 × 3; 31 | 32 | method help($msg) { 33 | “Like this: {$msg.server.current-nick}: f583f22 grep=SETTING:: say ‘hello’; say ‘world’” 34 | } 35 | 36 | multi method irc-to-me($msg where /^ \s* $=<.&commit-list> \s+ [‘grep=’ $=\S+ \s+]? $=.+ /) { 37 | self.process: $msg, ~$, ~($ // ‘SETTING::’), ~$ 38 | } 39 | 40 | sub condense(@arr) { # squish into ranges 41 | my $cur = False; 42 | gather for @arr { 43 | if $_ - 1 ~~ $cur { 44 | $cur = $cur.min .. $_ 45 | } else { 46 | take $cur if $cur !== False; 47 | $cur = $_ 48 | } 49 | LAST take $cur 50 | } 51 | } 52 | 53 | method process($msg, $config is copy, $grep, $code is copy) { 54 | my $start-time = now; 55 | 56 | if $config ~~ /^ [say|sub] $/ { 57 | reply $msg, “Seems like you forgot to specify a revision (will use “HEAD” instead of “$config”)”; 58 | $code = “$config $code”; 59 | $config = ‘HEAD’ 60 | } 61 | 62 | my @commits = get-commits $config; 63 | grumble ‘Coverable only works with one commit’ if @commits > 1; 64 | 65 | my $file = process-code $code, $msg; 66 | LEAVE .unlink with $file; 67 | 68 | my $result; 69 | my %lookup; 70 | my $output = ‘’; 71 | my $commit = @commits[0]; 72 | 73 | # convert to real ids so we can look up the builds 74 | my $full-commit = to-full-commit $commit; 75 | if not defined $full-commit { 76 | $output = ‘Cannot find this revision’; 77 | my @options = ; 78 | $output ~= “ (did you mean “{get-short-commit get-similar $commit, @options}”?)” 79 | } elsif not build-exists $full-commit { 80 | $output = ‘No build for this commit’ 81 | } else { # actually run the code 82 | my $log = $*TMPDIR.add: “coverage_{now.to-posix[0]}.log”; # TODO proper temp file name 83 | LEAVE { unlink $log } 84 | 85 | %*ENV = $log; 86 | $result = run-snippet $full-commit, $file; 87 | %*ENV:delete; 88 | 89 | my $g = run ‘grep’, ‘-P’, ‘--’, $grep, $log, :out; 90 | my $s = run ‘sort’, ‘--key=2,2’, ‘--key=3n’, ‘-u’, :in($g.out), :out; 91 | my $colrm = run ‘colrm’, 1, 5, :in($s.out), :out; 92 | $result = $colrm.out.slurp-rest.chomp; 93 | $output = $result; 94 | if $result < 0 { # numbers less than zero indicate other weird failures 95 | $output = “Cannot test this commit ($output)” 96 | } else { 97 | $output ~= “ «exit code = $result»” if $result ≠ 0; 98 | $output ~= “ «exit signal = {Signal($result)} ($result)»” if $result ≠ 0 99 | } 100 | } 101 | my $short-commit = get-short-commit $commit; 102 | $short-commit ~= “({get-short-commit $full-commit})” if $commit eq ‘HEAD’; 103 | 104 | if now - $start-time > TOTAL-TIME { 105 | grumble “«hit the total time limit of {TOTAL-TIME} seconds»” 106 | } 107 | 108 | my $result-str = “¦$full-commit: «$output»”; # TODO simpler output perhaps? 109 | 110 | my %coverage; 111 | for $result.split(“\n”) -> $line { 112 | my ($filename, $lineno) = $line.split: /\s+/; 113 | %coverage{$filename}.push: +$lineno; 114 | } 115 | 116 | my $cover-report = “| File | Code |\n|--|--|\n”; 117 | my $url = “https://github.com/rakudo/rakudo/blob/$full-commit”; 118 | for %coverage.keys.sort -> $fn { 119 | for condense %coverage{$fn} -> $l { 120 | my $ln = ‘L’ ~ ($l ~~ Int ?? $l !! “$l.min()-L$l.max()”); 121 | if $fn.starts-with(‘SETTING::’) or $fn ~~ m|‘/Perl6/’| { 122 | my $fname = $fn; 123 | $fname .= substr(9) if $fn.starts-with(‘SETTING::’); 124 | $cover-report ~= “| [$fname#$ln]($url/$fname#$ln) |”; 125 | my $sed-range = “{$l.min},{$l.max}p”; 126 | # ⚠ TODO don't do this ↓ for every line, do it for every *file*. It will be much faster. 127 | my $proc = run :out, :cwd($CONFIG), , “$full-commit:$fname”; 128 | # TODO So we are using RAKUDO ↑, but RAKUDO may not know about some commits *yet*, while 129 | # they may be accessible if you give a hash directly. 130 | my $code = run(:out, :in($proc.out), , $sed-range).out.slurp-rest.trim; # TODO trim? or just chomp? 131 | $code .= subst: :g, “\n”, ‘```
```’; # TODO multiline code blocks using github markdown? 132 | $code .= subst: :g, ‘|’, ‘\|’; # TODO really? 133 | $cover-report ~= “ ```$code``` |\n”; # TODO close properly (see how many ``` are there already) 134 | } else { 135 | $cover-report ~= “| $fn#$ln | |\n”; # TODO write “N/A” instead of having an empty cell? 136 | } 137 | } 138 | } 139 | 140 | (‘’ but ProperStr($result-str)) but FileStore(%(‘result.md’ => $cover-report)); 141 | } 142 | 143 | 144 | Coverable.new.selfrun: ‘coverable6’, [ / cover6? /, 145 | fuzzy-nick(‘coverable6’, 3) ]; 146 | 147 | # vim: expandtab shiftwidth=4 ft=perl6 148 | -------------------------------------------------------------------------------- /lib/Whateverable/Uniprops.pm6: -------------------------------------------------------------------------------- 1 | # Copyright © 2017-2023 2 | # Aleks-Daniel Jakimenko-Aleksejev 3 | # 4 | # This program is free software: you can redistribute it and/or modify 5 | # it under the terms of the GNU Affero General Public License as published by 6 | # the Free Software Foundation, either version 3 of the License, or 7 | # (at your option) any later version. 8 | # 9 | # This program is distributed in the hope that it will be useful, 10 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 11 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 | # GNU Affero General Public License for more details. 13 | # 14 | # You should have received a copy of the GNU Affero General Public License 15 | # along with this program. If not, see . 16 | 17 | unit package Whateverable::Uniprops; 18 | 19 | our @prop-table is export = 20 | ‘Numeric properties’ => ( 21 | (‘cjkAccountingNumeric’ ; ‘kAccountingNumeric’), 22 | (‘cjkOtherNumeric’ ; ‘kOtherNumeric’), 23 | (‘cjkPrimaryNumeric’ ; ‘kPrimaryNumeric’), 24 | (‘nv’ ; ‘Numeric_Value’), 25 | ), 26 | 27 | ‘String properties’ => ( 28 | (‘cf’ ; ‘Case_Folding’), 29 | (‘cjkCompatibilityVariant’ ; ‘kCompatibilityVariant’), 30 | (‘dm’ ; ‘Decomposition_Mapping’), 31 | (‘FC_NFKC’ ; ‘FC_NFKC_Closure’), 32 | (‘lc’ ; ‘Lowercase_Mapping’), 33 | (‘NFKC_CF’ ; ‘NFKC_Casefold’), 34 | (‘scf’ ; ‘Simple_Case_Folding’ ; ‘sfc’), 35 | (‘slc’ ; ‘Simple_Lowercase_Mapping’), 36 | (‘stc’ ; ‘Simple_Titlecase_Mapping’), 37 | (‘suc’ ; ‘Simple_Uppercase_Mapping’), 38 | (‘tc’ ; ‘Titlecase_Mapping’), 39 | (‘uc’ ; ‘Uppercase_Mapping’), 40 | ), 41 | 42 | 43 | ‘Miscellaneous properties’ => ( 44 | (‘bmg’ ; ‘Bidi_Mirroring_Glyph’), 45 | (‘bpb’ ; ‘Bidi_Paired_Bracket’), 46 | (‘cjkIICore’ ; ‘kIICore’), 47 | (‘cjkIRG_GSource’ ; ‘kIRG_GSource’), 48 | (‘cjkIRG_HSource’ ; ‘kIRG_HSource’), 49 | (‘cjkIRG_JSource’ ; ‘kIRG_JSource’), 50 | (‘cjkIRG_KPSource’ ; ‘kIRG_KPSource’), 51 | (‘cjkIRG_KSource’ ; ‘kIRG_KSource’), 52 | (‘cjkIRG_MSource’ ; ‘kIRG_MSource’), 53 | (‘cjkIRG_TSource’ ; ‘kIRG_TSource’), 54 | (‘cjkIRG_USource’ ; ‘kIRG_USource’), 55 | (‘cjkIRG_VSource’ ; ‘kIRG_VSource’), 56 | (‘cjkRSUnicode’ ; ‘kRSUnicode’ ; ‘Unicode_Radical_Stroke’; ‘URS’), 57 | (‘isc’ ; ‘ISO_Comment’), 58 | (‘JSN’ ; ‘Jamo_Short_Name’), 59 | (‘na’ ; ‘Name’), 60 | (‘na1’ ; ‘Unicode_1_Name’), 61 | (‘Name_Alias’ ; ‘Name_Alias’), 62 | (‘scx’ ; ‘Script_Extensions’), 63 | ), 64 | 65 | ‘Catalog properties’ => ( 66 | (‘age’ ; ‘Age’), 67 | (‘blk’ ; ‘Block’), 68 | (‘sc’ ; ‘Script’), 69 | ), 70 | 71 | ‘Enumerated properties’ => ( 72 | (‘bc’ ; ‘Bidi_Class’), 73 | (‘bpt’ ; ‘Bidi_Paired_Bracket_Type’), 74 | (‘ccc’ ; ‘Canonical_Combining_Class’), 75 | (‘dt’ ; ‘Decomposition_Type’), 76 | (‘ea’ ; ‘East_Asian_Width’), 77 | (‘gc’ ; ‘General_Category’), 78 | (‘GCB’ ; ‘Grapheme_Cluster_Break’), 79 | (‘hst’ ; ‘Hangul_Syllable_Type’), 80 | (‘InPC’ ; ‘Indic_Positional_Category’), 81 | (‘InSC’ ; ‘Indic_Syllabic_Category’), 82 | (‘jg’ ; ‘Joining_Group’), 83 | (‘jt’ ; ‘Joining_Type’), 84 | (‘lb’ ; ‘Line_Break’), 85 | (‘NFC_QC’ ; ‘NFC_Quick_Check’), 86 | (‘NFD_QC’ ; ‘NFD_Quick_Check’), 87 | (‘NFKC_QC’ ; ‘NFKC_Quick_Check’), 88 | (‘NFKD_QC’ ; ‘NFKD_Quick_Check’), 89 | (‘nt’ ; ‘Numeric_Type’), 90 | (‘SB’ ; ‘Sentence_Break’), 91 | (‘WB’ ; ‘Word_Break’), 92 | ), 93 | 94 | ‘Binary Properties’ => ( 95 | (‘AHex’ ; ‘ASCII_Hex_Digit’), 96 | (‘Alpha’ ; ‘Alphabetic’), 97 | (‘Bidi_C’ ; ‘Bidi_Control’), 98 | (‘Bidi_M’ ; ‘Bidi_Mirrored’), 99 | (‘Cased’ ; ‘Cased’), 100 | (‘CE’ ; ‘Composition_Exclusion’), 101 | (‘CI’ ; ‘Case_Ignorable’), 102 | (‘Comp_Ex’ ; ‘Full_Composition_Exclusion’), 103 | (‘CWCF’ ; ‘Changes_When_Casefolded’), 104 | (‘CWCM’ ; ‘Changes_When_Casemapped’), 105 | (‘CWKCF’ ; ‘Changes_When_NFKC_Casefolded’), 106 | (‘CWL’ ; ‘Changes_When_Lowercased’), 107 | (‘CWT’ ; ‘Changes_When_Titlecased’), 108 | (‘CWU’ ; ‘Changes_When_Uppercased’), 109 | (‘Dash’ ; ‘Dash’), 110 | (‘Dep’ ; ‘Deprecated’), 111 | (‘DI’ ; ‘Default_Ignorable_Code_Point’), 112 | (‘Dia’ ; ‘Diacritic’), 113 | (‘Ext’ ; ‘Extender’), 114 | (‘Gr_Base’ ; ‘Grapheme_Base’), 115 | (‘Gr_Ext’ ; ‘Grapheme_Extend’), 116 | (‘Gr_Link’ ; ‘Grapheme_Link’), 117 | (‘Hex’ ; ‘Hex_Digit’), 118 | (‘Hyphen’ ; ‘Hyphen’), 119 | (‘IDC’ ; ‘ID_Continue’), 120 | (‘Ideo’ ; ‘Ideographic’), 121 | (‘IDS’ ; ‘ID_Start’), 122 | (‘IDSB’ ; ‘IDS_Binary_Operator’), 123 | (‘IDST’ ; ‘IDS_Trinary_Operator’), 124 | (‘Join_C’ ; ‘Join_Control’), 125 | (‘LOE’ ; ‘Logical_Order_Exception’), 126 | (‘Lower’ ; ‘Lowercase’), 127 | (‘Math’ ; ‘Math’), 128 | (‘NChar’ ; ‘Noncharacter_Code_Point’), 129 | (‘OAlpha’ ; ‘Other_Alphabetic’), 130 | (‘ODI’ ; ‘Other_Default_Ignorable_Code_Point’), 131 | (‘OGr_Ext’ ; ‘Other_Grapheme_Extend’), 132 | (‘OIDC’ ; ‘Other_ID_Continue’), 133 | (‘OIDS’ ; ‘Other_ID_Start’), 134 | (‘OLower’ ; ‘Other_Lowercase’), 135 | (‘OMath’ ; ‘Other_Math’), 136 | (‘OUpper’ ; ‘Other_Uppercase’), 137 | (‘Pat_Syn’ ; ‘Pattern_Syntax’), 138 | (‘Pat_WS’ ; ‘Pattern_White_Space’), 139 | (‘PCM’ ; ‘Prepended_Concatenation_Mark’), 140 | (‘QMark’ ; ‘Quotation_Mark’), 141 | (‘Radical’ ; ‘Radical’), 142 | (‘SD’ ; ‘Soft_Dotted’), 143 | (‘STerm’ ; ‘Sentence_Terminal’), 144 | (‘Term’ ; ‘Terminal_Punctuation’), 145 | (‘UIdeo’ ; ‘Unified_Ideograph’), 146 | (‘Upper’ ; ‘Uppercase’), 147 | (‘VS’ ; ‘Variation_Selector’), 148 | (‘WSpace’ ; ‘White_Space ; space’), 149 | (‘XIDC’ ; ‘XID_Continue’), 150 | (‘XIDS’ ; ‘XID_Start’), 151 | (‘XO_NFC’ ; ‘Expands_On_NFC’), 152 | (‘XO_NFD’ ; ‘Expands_On_NFD’), 153 | (‘XO_NFKC’ ; ‘Expands_On_NFKC’), 154 | (‘XO_NFKD’ ; ‘Expands_On_NFKD’), 155 | ), 156 | 157 | ‘Emoji’ => ( 158 | (‘Emoji’), 159 | (‘Emoji_Presentation’), 160 | (‘Emoji_Modifier’), 161 | (‘Emoji_Modifier_Base’), 162 | (‘Emoji_All’), 163 | (‘Emoji_Zwj_Sequences’), 164 | ), 165 | 166 | ‘Implementation specific properties’ => ( 167 | (‘Numeric_Value_Numerator’), 168 | (‘Numeric_Value_Denominator’), 169 | (‘NFG_QC’), 170 | (‘MVM_COLLATION_PRIMARY’), 171 | (‘MVM_COLLATION_SECONDARY’), 172 | (‘MVM_COLLATION_TERTIARY’), 173 | (‘MVM_COLLATION_QC’), 174 | ), 175 | 176 | # vim: expandtab shiftwidth=4 ft=perl6 177 | -------------------------------------------------------------------------------- /lib/Whateverable/Bits.pm6: -------------------------------------------------------------------------------- 1 | # Copyright © 2016-2020 2 | # Aleks-Daniel Jakimenko-Aleksejev 3 | # Copyright © 2016 4 | # Daniel Green 5 | # 6 | # This program is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU Affero General Public License as published by 8 | # the Free Software Foundation, either version 3 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # This program is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU Affero General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU Affero General Public License 17 | # along with this program. If not, see . 18 | 19 | 20 | # This file is a collection of tiny general purpose 21 | # functions and other things. 22 | 23 | role Helpful { method help($msg) { … } } 24 | 25 | role Reply { has $.msg } 26 | role ProperStr { has $.long-str } 27 | role PrettyLink { has &.link-msg } 28 | role FileStore { has %.additional-files } 29 | 30 | #| Reply and also mix in the Reply role so that gists have more info 31 | sub reply($msg, $response) is export { 32 | $msg.reply: $response but Reply($msg) 33 | } 34 | 35 | sub shorten($str, $max, $cutoff=$max ÷ 2) is export { 36 | $max ≥ $str.chars ?? $str !! $str.substr(0, $cutoff - 1) ~ ‘…’ 37 | } 38 | 39 | sub fuzzy-nick($nick, $distance) is export { 40 | use Text::Diff::Sift4; 41 | / \w+ / 42 | } 43 | 44 | sub signal-to-text($signal) is export { 45 | “$signal ({$signal ?? Signal($signal) !! ‘None’})” 46 | } 47 | 48 | sub ss($var is rw) is export { 49 | s(+$var, $var.VAR.name.trans(‘-’ => ‘ ’, /\W/ => ‘’, /s$/ => ‘’)) 50 | } 51 | sub s($count, $word) is export { 52 | +$count ~ ‘ ’ ~ $word ~ ($count == 1 ?? ‘’ !! ‘s’) 53 | } 54 | 55 | sub maybe($format, $string) is export { 56 | $string ?? $string.fmt: $format !! ‘’ 57 | } 58 | 59 | sub markdown-escape($text) is export { 60 | # TODO is it correct? No, that's an ugly hack… 61 | $text.trans: (｢<｣, ｢>｣, ｢&｣, ｢\｣, ｢`｣, ｢*｣, ｢_｣, ｢~｣, ｢|｣) => 62 | (｢\<｣, ｢\>｣, ｢\&｣, ｢\\｣, ｢\`｣, ｢\*｣, ｢\_｣, ｢\~｣, ｢\|｣); # ｣); 63 | } 64 | 65 | sub html-escape($text) is export { 66 | $text.trans: (‘&’, ‘<’, ‘>’) => (‘&’, ‘<’, ‘>’) 67 | } 68 | 69 | my token irc-nick is export { 70 | [ 71 | | <[a..zA..Z0..9]> 72 | | ‘-’ | ‘_’ | ‘[’ | ‘]’ | ‘{’ | ‘}’ | ‘\\’ | ‘`’ | ‘|’ 73 | ]+ 74 | } 75 | 76 | my token commit-list is export { 77 | [<-[\s] -[‘,’]>+]+ % [‘,’\s*] 78 | } 79 | 80 | #| Get the closest fuzzy match 81 | sub did-you-mean($string, @options, :$default=Nil, 82 | :$max-offset=7, :$max-distance=10) is export { 83 | my $answer = $default; 84 | my $answer-min = ∞; 85 | my $distance-limit = $max-distance + 1; 86 | $distance-limit = 17 if $distance-limit < 17; 87 | 88 | use Text::Diff::Sift4; 89 | for @options { 90 | my $distance = sift4 $_, $string, $max-offset, $distance-limit; 91 | if $distance < $answer-min { 92 | $answer = $_; 93 | $answer-min = $distance; 94 | } 95 | } 96 | return $default if $answer-min > $max-distance; 97 | $answer 98 | } 99 | 100 | sub time-left(Instant() $then, :$already-there?, :$simple=False) is export { 101 | my $time-left = $then - now; 102 | return $already-there if $already-there and $time-left < 0; 103 | my ($seconds, $minutes, $hours, $days) = $time-left.polymod: 60, 60, 24; 104 | if not $days and not $hours { 105 | return $simple ?? ‘in a minute’ !! ‘is just a few moments away’ unless $minutes; 106 | return ($simple ?? ‘in ’ !! ‘is in ’) ~ ss $minutes; 107 | } 108 | my $answer = ‘in ’; 109 | $answer ~= ss($days) ~ ‘ and ’ if $days; 110 | $answer ~= ‘≈’ ~ ss $hours; 111 | $answer 112 | } 113 | 114 | #| Just like .join but wraps around 115 | sub limited-join(@list, :$limit=70) is export { 116 | my $cur = ‘’; 117 | gather for @list { 118 | if $cur and ($cur ~ $_).chars > $limit { # wrap 119 | take “$cur,”; 120 | $cur = ‘’ 121 | } 122 | $cur ~= ‘,’ if $cur; 123 | $cur ~= $_; 124 | LAST take $cur 125 | }.join: “\n ” 126 | } 127 | 128 | #| Get current timestamp (DateTime) 129 | sub timestampish is export { DateTime.now(:0timezone).truncated-to: ‘seconds’ } 130 | 131 | #↓ Spurt into a tempfile. 132 | sub write-code($code --> IO) is export { 133 | use File::Temp; 134 | my ($filename, $filehandle) = tempfile :!unlink; 135 | $filehandle.print: $code; 136 | $filehandle.close; 137 | $filename.IO 138 | } 139 | 140 | #| Use Cro to fetch from a URL (like GitHub API) 141 | sub curl($url, :@headers) is export { 142 | use Cro::HTTP::Client; 143 | use Whateverable::Config; 144 | my @new-headers = @headers; 145 | @new-headers.push: (User-Agent => ‘Whateverable’); 146 | if $url.starts-with: ‘https://api.github.com/’ and $CONFIG { 147 | @new-headers.push: (Authorization => ‘token ’ ~ $CONFIG); 148 | } 149 | my Cro::HTTP::Client $client .= new: headers => @new-headers; 150 | my $resp = await $client.get: $url; 151 | my $return = await $resp.body; 152 | 153 | # Extra stuff in case you need it 154 | # Next url 155 | my $next = $resp.headers.first(*.name eq ‘Link’).?value; 156 | if $next && $next ~~ /‘<’ (<-[>]>*?) ‘>; rel="next"’/ { 157 | my $next-url = ~$0; 158 | role NextURL { has $.next-url }; 159 | $return = $return but NextURL($next-url); 160 | } 161 | # Rate limiting 162 | my $rate-limit = $resp.headers.first(*.name eq ‘X-RateLimit-Remaining’).?value; 163 | my $rate-limit-reset = $resp.headers.first(*.name eq ‘X-RateLimit-Reset’).?value; 164 | $rate-limit-reset -= time; # time to sleep instead of when to wake up 165 | if $rate-limit.defined and $rate-limit < 5 { 166 | role RateLimited { has $.rate-limit-reset-in } 167 | $return = $return but RateLimited($rate-limit-reset); 168 | } 169 | 170 | $return 171 | } 172 | 173 | # Exceptions 174 | class Whateverable::X::HandleableAdHoc is X::AdHoc is export {} 175 | 176 | sub grumble(|c) is export { 177 | Whateverable::X::HandleableAdHoc.new(payload => c).throw 178 | } 179 | 180 | # vim: expandtab shiftwidth=4 ft=perl6 181 | -------------------------------------------------------------------------------- /lib/Whateverable/Running.pm6: -------------------------------------------------------------------------------- 1 | # Copyright © 2016-2023 2 | # Aleks-Daniel Jakimenko-Aleksejev 3 | # Copyright © 2016 4 | # Daniel Green 5 | # 6 | # This program is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU Affero General Public License as published by 8 | # the Free Software Foundation, either version 3 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # This program is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU Affero General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU Affero General Public License 17 | # along with this program. If not, see . 18 | 19 | use File::Directory::Tree; 20 | 21 | use Whateverable::Config; 22 | use Whateverable::Heartbeat; 23 | use Whateverable::Bits; 24 | use Whateverable::Output; 25 | use Whateverable::Builds; 26 | 27 | unit module Whateverable::Running; 28 | 29 | #↓ Unpacks a build, runs $code and cleans up. 30 | sub run-smth($full-commit-hash, Code $code, 31 | :$backend=‘rakudo-moar’, 32 | :$wipe = True, :$lock = True) is export { 33 | my $build-path = run-smth-build-path $full-commit-hash, :$backend; 34 | my $archive-path = “$CONFIG{$backend}/$full-commit-hash.tar.zst”; 35 | my $archive-link = “$CONFIG{$backend}/$full-commit-hash”; 36 | 37 | # create all parent directories just in case 38 | # (may be needed for isolated /tmp) 39 | mkdir $build-path.IO.parent; 40 | 41 | if $lock { 42 | # lock on the destination directory to make 43 | # sure that other bots will not get in our way. 44 | while run(:err(Nil), ‘mkdir’, ‘--’, $build-path).exitcode ≠ 0 { 45 | test-delay if %*ENV; 46 | note “$build-path is locked. Waiting…”; 47 | sleep 0.5 # should never happen if configured correctly (kinda) 48 | } 49 | 50 | my $proc1; 51 | my $proc2; 52 | if $archive-path.IO ~~ :e { 53 | if run :err(Nil), { # check that pzstd is available 54 | $proc1 = run :out, :bin, , $archive-path; 55 | $proc2 = run :in($proc1.out), :bin, ; 56 | } else { 57 | die ‘zstd is not installed’ unless run :out(Nil), ; 58 | # OK we are using zstd from the Mesozoic Era 59 | $proc1 = run :out, :bin, , $archive-path; 60 | $proc2 = run :in($proc1.out), :bin, ; 61 | } 62 | } else { 63 | die ‘lrzip is not installed’ unless run :err(Nil), ; # check that lrzip is available 64 | $proc1 = run :out, :bin, , $archive-link; 65 | $proc2 = run :in($proc1.out), :bin, , $build-path; 66 | } 67 | 68 | if not $proc1 or not $proc2 { 69 | note “Broken archive for $full-commit-hash, removing…”; 70 | try unlink $archive-path; 71 | try unlink $archive-link; 72 | rmtree $build-path; 73 | return %(output => ‘Broken archive’, exit-code => -1, signal => -1, time => -1,) 74 | } 75 | } 76 | 77 | my $return = $code($build-path); # basically, we wrap around $code 78 | rmtree $build-path if $wipe; 79 | $return 80 | } 81 | 82 | #| Returns path to the unpacked build. This is useful if you want to 83 | #| use some build multiple times simultaneously (just pass that path 84 | #| to the code block). 85 | sub run-smth-build-path($full-commit-hash, :$backend=‘rakudo-moar’) is export { 86 | “$CONFIG/$backend/$full-commit-hash”; 87 | } 88 | 89 | 90 | sub run-snippet($full-commit-hash, $file, 91 | :$backend=‘rakudo-moar’, 92 | :@args=Empty, 93 | :$timeout=%*BOT-ENV // 10, 94 | :$stdin=$CONFIG, 95 | :$ENV, 96 | :$wipe = True, :$lock = True, 97 | ) is export { 98 | run-smth :$wipe, :$lock, :$backend, $full-commit-hash, -> $path { 99 | my $binary-path = $path.IO.add: ‘bin/perl6’; 100 | my %tweaked-env = $ENV // %*ENV; 101 | %tweaked-env = join ‘:’, $binary-path.parent, (%tweaked-env // Empty); 102 | %tweaked-env = ‘sandbox/lib’; 103 | $binary-path.IO !~~ :e 104 | ?? %(output => ‘Commit exists, but an executable could not be built for it’, 105 | exit-code => -1, signal => -1, time => -1,) 106 | !! get-output $binary-path, |@args, 107 | ‘--’, $file, :$stdin, :$timeout, ENV => %tweaked-env, :!chomp 108 | } 109 | } 110 | 111 | #↓ Greps through text using a perl6 snippet. 112 | sub perl6-grep($stdin, $regex is copy, :$timeout = 180, :$complex = False, :$hack = 0) is export { 113 | my $full-commit = to-full-commit ‘HEAD’ ~ (‘^’ x $hack); 114 | die “No build for $full-commit. Oops!” unless build-exists $full-commit; 115 | $regex = “m⦑ $regex ⦒”; 116 | # TODO can we do something smarter? 117 | my $sep = $complex ?? ｢“\0\0”｣ !! ｢“\0”｣; 118 | my $magic = “INIT \$*ARGFILES.nl-in = $sep; INIT \$*OUT.nl-out = $sep;” 119 | ~ ｢use nqp;｣ 120 | ~ ｢ next unless｣ 121 | ~ ($complex ?? ｢ nqp::substr($_, 0, nqp::index($_, “\0”)) ~~｣ !! ‘’) ~ “\n” 122 | ~ $regex ~ “;\n” 123 | ~ ｢last if $++ > ｣ ~ $CONFIG; 124 | my $file = write-code $magic; 125 | LEAVE unlink $_ with $file; 126 | my $result = run-snippet $full-commit, $file, :$timeout, :$stdin, args => (‘-np’,); 127 | my $output = $result; 128 | # numbers less than zero indicate other weird failures ↓ 129 | grumble “Something went wrong ($output)” if $result < 0; 130 | 131 | $output ~= “ «exit code = $result»” if $result ≠ 0; 132 | $output ~= “ «exit signal = {Signal($result)} ($result)»” if $result ≠ 0; 133 | grumble $output if $result ≠ 0 or $result ≠ 0; 134 | my @elems = $output.split: ($complex ?? “\0\0” !! “\0”), :skip-empty; 135 | if @elems > $CONFIG { 136 | grumble “Cowardly refusing to gist more than $CONFIG lines” 137 | } 138 | @elems 139 | } 140 | 141 | # vim: expandtab shiftwidth=4 ft=perl6 142 | -------------------------------------------------------------------------------- /xt/notable.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | BEGIN %*ENV = 1; 3 | %*ENV = 1; 4 | 5 | use lib ; 6 | use Test; 7 | use Testable; 8 | 9 | my $t = Testable.new: bot => ‘Notable’; 10 | 11 | $t.common-tests: help => “Like this: {$t.bot-nick}: weekly rakudo is now 10x as fast”; 12 | 13 | $t.shortcut-tests: (‘weekly:’,), 14 | ; 15 | 16 | $t.test(‘fallback’, 17 | “{$t.bot-nick}: wazzup?”, 18 | “{$t.our-nick}, I cannot recognize this command. See wiki for some examples: https://github.com/Raku/whateverable/wiki/Notable”); 19 | 20 | # No notes 21 | 22 | my regex date { \d\d\d\d\-\d\d\-\d\dT\d\d\:\d\d\:\d\dZ } 23 | 24 | $t.test(‘no notes’, 25 | “{$t.bot-nick}: blah”, 26 | “{$t.our-nick}, No notes for “blah””); 27 | 28 | $t.test(‘no notes (shortcut)’, 29 | “weekly:”, 30 | “{$t.our-nick}, No notes for “weekly””); 31 | 32 | $t.test(‘no notes, clearing’, 33 | “{$t.bot-nick}: clear blah”, 34 | “{$t.our-nick}, No notes for “blah””); 35 | 36 | $t.test(‘no notes, clearing (shortcut)’, 37 | “weekly: clear”, 38 | “{$t.our-nick}, No notes for “weekly””); 39 | 40 | $t.test(‘list topics’, 41 | “{$t.bot-nick}: list”, 42 | “{$t.our-nick}, No notes yet”); 43 | 44 | # Creating notes 45 | 46 | $t.test(:!both, ‘create new topic’, 47 | “{$t.bot-nick}: new-topic blah”, 48 | “{$t.our-nick}, New topic added (“blah”)”); 49 | 50 | $t.test(‘try to create the same topic again’, 51 | “{$t.bot-nick}: new-topic blah”, 52 | “{$t.our-nick}, Topic “blah” already exists”); 53 | 54 | $t.test(:!both, ‘note something’, 55 | “{$t.bot-nick}: blah foo”, 56 | “{$t.our-nick}, Noted! (blah)”); 57 | 58 | $t.test(‘list topics (with notes)’, 59 | “{$t.bot-nick}: list”, 60 | “{$t.our-nick}, blah”); 61 | 62 | $t.test(:!both, ‘note something (shortcut)’, 63 | “weekly: Monday”, 64 | “{$t.our-nick}, Noted! (weekly)”); 65 | 66 | $t.test(‘list topics (with notes)’, 67 | “{$t.bot-nick}: list”, 68 | “{$t.our-nick}, blah weekly”); 69 | 70 | 71 | $t.test(‘list notes’, 72 | “{$t.bot-nick}: blah”, 73 | /^‘, 1 note: ’‘ <’‘>: foo’$/); 74 | 75 | $t.test(‘list notes (shortcut)’, 76 | “weekly:”, 77 | /^‘, 1 note: ’‘ <’‘>: Monday’$/); 78 | 79 | 80 | # Clearing notes 81 | 82 | my $moved; 83 | my $moved-shortcut; 84 | 85 | $t.test(:!both, ‘clear’, 86 | “{$t.bot-nick}: clear blah”, 87 | /^‘, Moved existing notes to “blah_’‘”’$ 88 | {$moved=$}/); 89 | 90 | $t.test(:!both, ‘clear (shortcut)’, 91 | “weekly: clear”, 92 | /^‘, Moved existing notes to “weekly_’‘”’$ 93 | {$moved-shortcut=$}/); 94 | 95 | $t.test(‘list moved notes’, 96 | “{$t.bot-nick}: blah_$moved”, 97 | /^‘, 1 note: ’‘ <’‘>: foo’$/); 98 | 99 | $t.test(‘list moved notes (can't use a shortcut, but still)’, 100 | “{$t.bot-nick}: weekly_$moved-shortcut”, 101 | /^‘, 1 note: ’‘ <’‘>: Monday’$/); 102 | 103 | $t.test(‘empty after clearing’, 104 | “{$t.bot-nick}: clear blah”, 105 | “{$t.our-nick}, No notes for “blah””); 106 | 107 | $t.test(‘empty after clearing (shortcut)’, 108 | “weekly: clear”, 109 | “{$t.our-nick}, No notes for “weekly””); 110 | 111 | 112 | $t.test(:!both, ‘re-create blah topic’, 113 | “{$t.bot-nick}: new-category blah”, 114 | “{$t.our-nick}, New topic added (“blah”)”); 115 | 116 | $t.test(:!both, ‘note something after clearing’, 117 | “{$t.bot-nick}: blah foo”, 118 | “{$t.our-nick}, Noted! (blah)”); 119 | 120 | $t.test(:!both, ‘note something after clearing (shortcut)’, 121 | “weekly: Monday”, 122 | “{$t.our-nick}, Noted! (weekly)”); 123 | 124 | $t.test(‘list notes after clearing’, 125 | “{$t.bot-nick}: blah”, 126 | /^‘, 1 note: ’‘ <’‘>: foo’$/); 127 | 128 | $t.test(‘list notes after clearing (shortcut)’, 129 | “weekly:”, 130 | /^‘, 1 note: ’‘ <’‘>: Monday’$/); 131 | 132 | $t.test(:!both, ‘note something again’, 133 | “{$t.bot-nick}: blah bar”, 134 | “{$t.our-nick}, Noted! (blah)”); 135 | 136 | $t.test(:!both, ‘note something again (shortcut)’, 137 | “weekly: Tuesday”, 138 | “{$t.our-nick}, Noted! (weekly)”); 139 | 140 | 141 | $t.test(‘list two notes’, 142 | “{$t.bot-nick}: blah”, 143 | /^‘, 2 notes: ’‘ <’‘>: foo ; ’‘ <’‘>: bar’$/); 144 | 145 | $t.test(‘list two notes (shortcut)’, 146 | “weekly:”, 147 | /^‘, 2 notes: ’‘ <’‘>: Monday ; ’‘ <’‘>: Tuesday’$/); 148 | 149 | $t.test(:!both, ‘note something big’, 150 | “{$t.bot-nick}: blah {‘z’ x 300}”, 151 | “{$t.our-nick}, Noted! (blah)”); 152 | 153 | $t.test(:!both, ‘note something big (shortcut)’, 154 | “weekly: {‘Z’ x 300}”, 155 | “{$t.our-nick}, Noted! (weekly)”); 156 | 157 | # DWIM 158 | 159 | $t.test(‘clear …’, 160 | “{$t.bot-nick}: clear DWIM”, 161 | “{$t.our-nick}, No notes for “DWIM””); 162 | 163 | $t.test(‘reset …’, 164 | “{$t.bot-nick}: reset DWIM”, 165 | “{$t.our-nick}, No notes for “DWIM””); 166 | 167 | $t.test(‘delete …’, 168 | “{$t.bot-nick}: delete DWIM”, 169 | “{$t.our-nick}, No notes for “DWIM””); 170 | 171 | 172 | $t.test(‘… clear’, 173 | “{$t.bot-nick}: DWIM clear”, 174 | “{$t.our-nick}, No notes for “DWIM””); 175 | 176 | $t.test(‘… reset’, 177 | “{$t.bot-nick}: DWIM reset”, 178 | “{$t.our-nick}, No notes for “DWIM””); 179 | 180 | $t.test(‘… delete’, 181 | “{$t.bot-nick}: DWIM delete”, 182 | “{$t.our-nick}, No notes for “DWIM””); 183 | 184 | 185 | $t.test(:!both, ‘no topic specified’, 186 | “{$t.bot-nick}: just note it somewhere”, 187 | “{$t.our-nick}, Noted! (weekly)”); 188 | 189 | $t.test(‘no new topic created’, 190 | “{$t.bot-nick}: just”, 191 | “{$t.our-nick}, No notes for “just””); 192 | 193 | # TODO adapt test once the format is changed to markdown 194 | 195 | $t.test(‘gist’, 196 | “{$t.bot-nick}: blah”, 197 | “{$t.our-nick}, 3 notes: https://whatever.able/fakeupload”); 198 | 199 | $t.test-gist(‘correct gist’, 200 | %(‘result’ => /^‘ <’$($t.our-nick)‘>: foo’\n 201 | ‘ <’$($t.our-nick)‘>: bar’\n 202 | ‘ <’$($t.our-nick)‘>: ’$(‘z’ x 300) 203 | $/)); 204 | 205 | $t.test(‘gist (shortcut)’, 206 | “weekly:”, 207 | “{$t.our-nick}, 4 notes: https://whatever.able/fakeupload”); 208 | 209 | $t.test-gist(‘correct gist (shortcut)’, 210 | %(‘result’ => /^‘ <’$($t.our-nick)‘>: Monday’\n 211 | ‘ <’$($t.our-nick)‘>: Tuesday’\n 212 | ‘ <’$($t.our-nick)‘>: ’$(‘Z’ x 300)\n 213 | ‘ <’$($t.our-nick)‘>: just note it somewhere’ 214 | $/)); 215 | 216 | $t.last-test; 217 | done-testing; 218 | END $t.end; 219 | 220 | # vim: expandtab shiftwidth=4 ft=perl6 221 | -------------------------------------------------------------------------------- /lib/Whateverable/Bisection.pm6: -------------------------------------------------------------------------------- 1 | # Copyright © 2016-2019 2 | # Aleks-Daniel Jakimenko-Aleksejev 3 | # Copyright © 2016 4 | # Daniel Green 5 | # 6 | # This program is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU Affero General Public License as published by 8 | # the Free Software Foundation, either version 3 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # This program is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU Affero General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU Affero General Public License 17 | # along with this program. If not, see . 18 | 19 | use Whateverable::Bits; 20 | use Whateverable::Builds; 21 | use Whateverable::Config; 22 | use Whateverable::Output; 23 | use Whateverable::Running; 24 | 25 | unit module Whateverable::Bisection; 26 | 27 | enum RevisionType is export ; 28 | 29 | #↓ Use this to bisect stuff across a bunch of builds 30 | #↓ It can be used to bisect anything (not just Rakudo), it 31 | #↓ all depends on what you provide in &runner and :$repo-cwd. 32 | sub run-bisect(&runner = &standard-runner, #← Something to run on every revision 33 | &decider = &adaptive-decider, #← Something to classify the result from &runner 34 | :$skip-missing-builds = True, #← True to Skip if not build-exists 35 | :$repo-cwd, #← Repo path where we will run `git bisect` 36 | *%custom, #← Anything that may be needed in &runner or &decider 37 | ) is export { 38 | my $status; 39 | my $first-new-commit; 40 | 41 | my @bisect-log = gather loop { 42 | NEXT take “»»»»» {‘-’ x 73}”; # looks a bit nicer this way 43 | my $current-commit = get-output(cwd => $repo-cwd, 44 | ); 45 | take “»»»»» Testing $current-commit”; 46 | 47 | my $revision-type; 48 | if $skip-missing-builds and not build-exists $current-commit { 49 | take ‘»»»»» Build does not exist, skip this commit’; 50 | $revision-type = Skip; 51 | } else { 52 | my $run-result = &runner( :$current-commit, |%custom); 53 | $revision-type = &decider($run-result, :$current-commit, |%custom); 54 | } 55 | 56 | my $result = get-output cwd => $repo-cwd, , $revision-type.lc; 57 | $status = $result; 58 | 59 | if $result ~~ /^^ (\S+) ‘ is the first new commit’ / { 60 | $first-new-commit = ~$0; 61 | take $result; 62 | last 63 | } 64 | if $status == 2 { 65 | my $good-revs = get-output(:cwd($repo-cwd), , 66 | ‘--format=%(objectname)’, ‘refs/bisect/old-*’); 67 | my @possible-revs = get-output(:cwd($repo-cwd), , 68 | , |$good-revs.lines).lines; 69 | $first-new-commit = @possible-revs; 70 | take $result; 71 | last 72 | } 73 | if $status ≠ 0 { 74 | take $result; 75 | last 76 | } 77 | } 78 | my $log = @bisect-log.join(“\n”); 79 | %( :$log, :$status, :$first-new-commit ) 80 | } 81 | 82 | #↓ Runs a file containing a code snippet. Needs :$code-file custom arg. 83 | sub standard-runner(:$current-commit!, :$code-file!, *%_) is export { 84 | run-snippet $current-commit, $code-file 85 | } 86 | 87 | #↓ Takes an output of run-snippet or get-output and uses it to decide 88 | #↓ what to do. You must provide exactly one named 89 | #↓ argument ($old-exit-code, $old-exit-signal, $old-output). 90 | #↓ Generally it considers any deviation from $old-* to be the New 91 | #↓ behavior, so effectively it finds the first change. Whether 92 | #↓ that change is good or not is left for user discretion, here we 93 | #↓ just work with Old / New / Skip concepts. 94 | sub adaptive-decider($result, 95 | :$current-commit, 96 | :$old-exit-code, 97 | :$old-exit-signal, 98 | :$old-output, 99 | *%_) is export { 100 | 101 | if $result < 0 { # TODO use something different. … like what? 102 | take “»»»»» Cannot test this commit. Reason: $result”; 103 | take ‘»»»»» Therefore, skipping this revision’; 104 | return Skip # skip failed builds 105 | } 106 | 107 | take ‘»»»»» Script output:’; 108 | my $short-output = shorten $result, $CONFIG; 109 | take $short-output; 110 | if $short-output ne $result { 111 | take “»»»»» (output was trimmed because it is too large)” 112 | } 113 | 114 | take “»»»»» Script exit code: $result”; 115 | take “»»»»» Script exit signal: {signal-to-text $result}” 116 | if $result; 117 | 118 | if $result == 125 { 119 | take ‘»»»»» Exit code 125 means “skip”’; 120 | take ‘Therefore, skipping this revision as you requested’; 121 | return Skip # somebody did “exit 125” in their code on purpose 122 | } 123 | 124 | # compare signals 125 | with $old-exit-signal { 126 | take ‘»»»»» Bisecting by exit signal’; 127 | take “»»»»» Current exit signal is {signal-to-text $result},” 128 | ~ “ exit signal on “old” revision is {signal-to-text $old-exit-signal}”; 129 | if $old-exit-signal ≠ 0 { 130 | take “»»»»» Note that on “old” revision exit signal is normally” 131 | ~ “ {signal-to-text 0}, you are probably trying” 132 | ~ “ to find when something was fixed” 133 | } 134 | take ‘»»»»» If exit signal is not the same as on “old” revision,’ 135 | ~ ‘ this revision will be marked as “new”’; 136 | my $revision-type = $result == $old-exit-signal ?? Old !! New; 137 | take “»»»»» Therefore, marking this revision as “{$revision-type.lc}””; 138 | return $revision-type 139 | } 140 | 141 | # compare exit code (typically like a normal ｢git bisect run …｣) 142 | with $old-exit-code { 143 | take ‘»»»»» Bisecting by exit code’; 144 | take “»»»»» Current exit code is $result, ” 145 | ~ “exit code on “old” revision is $old-exit-code”; 146 | if $old-exit-code ≠ 0 { 147 | take ‘»»»»» Note that on “old” revision exit code is normally 0,’ 148 | ~ ‘ you are probably trying to find when something was fixed’ 149 | } 150 | take ‘»»»»» If exit code is not the same as on “old” revision,’ 151 | ~ ‘ this revision will be marked as “new”’; 152 | my $revision-type = $result == $old-exit-code ?? Old !! New; 153 | take “»»»»» Therefore, marking this revision as “{$revision-type.lc}””; 154 | return $revision-type 155 | } 156 | 157 | # compare the output 158 | with $old-output { 159 | take ‘»»»»» Bisecting by output’; 160 | take ‘»»»»» Output on “old” revision is:’; 161 | take $old-output; 162 | my $revision-type = $result eq $old-output ?? Old !! New; 163 | take “»»»»» The output is {$revision-type == Old 164 | ?? ‘identical’ !! ‘different’}”; 165 | take “»»»»» Therefore, marking this revision as “{$revision-type.lc}””; 166 | return $revision-type 167 | } 168 | } 169 | -------------------------------------------------------------------------------- /xbin/Linkable.p6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | # Copyright © 2019-2023 3 | # Aleks-Daniel Jakimenko-Aleksejev 4 | # Copyright © 2017-2018 5 | # Zoffix Znet 6 | # 7 | # This program is free software: you can redistribute it and/or modify 8 | # it under the terms of the GNU Affero General Public License as published by 9 | # the Free Software Foundation, either version 3 of the License, or 10 | # (at your option) any later version. 11 | # 12 | # This program is distributed in the hope that it will be useful, 13 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | # GNU Affero General Public License for more details. 16 | # 17 | # You should have received a copy of the GNU Affero General Public License 18 | # along with this program. If not, see . 19 | 20 | use Whateverable; 21 | use Whateverable::Bits; 22 | 23 | unit class Linkable does Whateverable; 24 | 25 | method help($msg) { 26 | ‘Like this: R#1946 D#1234 MOAR#768 NQP#509 SPEC#242 RT#126800 S09:320 524f98cdc’ 27 | } 28 | method private-messages-allowed() { True } 29 | 30 | constant %TICKET-URLS = %( 31 | ‘R’ | ‘RAKUDO’ | ‘GH’ => ‘https://api.github.com/repos/rakudo/rakudo/issues/’, 32 | ‘M’ | ‘MOAR’ | ‘MOARVM’ => ‘https://api.github.com/repos/MoarVM/MoarVM/issues/’, 33 | ‘N’ | ‘NQP’ => ‘https://api.github.com/repos/Raku/nqp/issues/’, 34 | ‘S’ | ‘SPEC’ | ‘ROAST’ => ‘https://api.github.com/repos/Raku/roast/issues/’, 35 | ‘D’ | ‘DOC’ | ‘DOCS’ => ‘https://api.github.com/repos/Raku/doc/issues/’, 36 | ‘PS’ => ‘https://api.github.com/repos/Raku/problem-solving/issues/’, 37 | ); 38 | 39 | sub bold($_) { $_ } 40 | # XXX ↓ currently it's too smart and it will escape it… hmm… 41 | # sub bold($_) { use IRC::TextColor; ircstyle :bold, $_ } 42 | 43 | my $RECENT-EXPIRY = %*ENV || %*ENV ?? 5 !! 2 × 60; 44 | my %recently; 45 | sub recent($what) { 46 | # throw away old entries 47 | %recently .= grep: now - *.value ≤ $RECENT-EXPIRY; 48 | 49 | LEAVE %recently{$what} = now; # mark it 50 | %recently{$what}:exists 51 | } 52 | 53 | my Channel $channel-messages .= new; 54 | 55 | sub link-reply($msg, $answer) { 56 | return if recent “{$msg.?channel // $msg.nick}\0$answer”; 57 | sleep 3 if $msg.nick eq ‘Geth’; 58 | $channel-messages.send: %(:$msg, :$answer) 59 | } 60 | 61 | start react whenever $channel-messages.Supply.throttle: 3, 3 -> $ (:$msg, :$answer) { 62 | $msg.irc.send: :where($msg.?channel // $msg.nick), text => $answer; 63 | } 64 | 65 | sub link-doc-page($msg, $match) { 66 | my $path = ~$match; 67 | $path .= subst: /^ ‘doc/’ /, ‘’; 68 | $path .= subst: / [‘.rakudoc’ | ‘.pod6’] $/, ‘’; 69 | if $path.contains: ‘Type’ { 70 | $path .= subst: ‘Type’, ‘type’; 71 | $path .= subst: ‘/’, ‘::’, :th(2..*); 72 | } else { 73 | $path .= subst: ‘Language’, ‘language’ 74 | } 75 | link-reply $msg, “Link: https://docs.raku.org/$path” 76 | } 77 | 78 | sub link-old-design-docs($msg, $match) { 79 | $/ = $match; 80 | my $syn = $ ?? “$/$” !! $; 81 | my $anchor = $ ?? “line_” ~ $ !! $; 82 | link-reply $msg, “Link: https://design.Raku.org/$syn.html#$anchor” 83 | } 84 | 85 | sub link-github-ticket($msg, $match) { 86 | my $prefix = ($match // $match).uc; 87 | my $id = $match; 88 | with fetch $prefix, $id { 89 | link-reply $msg, “{bold “$prefix#{.} [{.}]”}: {.} {bold .}” 90 | } 91 | } 92 | 93 | sub link-rt-ticket($msg, $match) { 94 | # XXX temporary solution? or maybe not? 95 | my $id = +$match<id>; 96 | my $ticket-snapshot = ‘data/reportable/’.IO.dir.sort.tail.add(‘RT’).add($id); 97 | next unless $ticket-snapshot.e; 98 | my $data = from-json $ticket-snapshot.slurp; 99 | my $url = “https://rt.perl.org/Ticket/Display.html?id=$id”; 100 | $url ~= “ https://rt-archive.perl.org/perl6/Ticket/Display.html?id=$id”; 101 | with $data { 102 | link-reply $msg, “{bold “RT#$id [{.<Status>}]”}: {bold .<Subject>} $url” 103 | } 104 | } 105 | 106 | sub link-commit($msg, $match) { 107 | my $sha = $match<id>; 108 | my $data = try curl “https://api.github.com/search/commits?q=$sha”, 109 | headers => (Accept => ‘application/vnd.github.cloak-preview’,); 110 | return without $data; 111 | my %json := $data; 112 | if %json<items> == 1 { 113 | my $commit = %json<items>[0]; 114 | my $short-sha = $commit<sha>.substr: 0, 10; # XXX use get-short-commit ? 115 | my $url = $commit<html_url>.subst: $commit<sha>, $short-sha; 116 | my $title = $commit<commit><message>.lines[0]; 117 | my $date = DateTime.new($commit<commit><author><date>).Date; 118 | link-reply $msg, “($date) $url $title” 119 | } 120 | } 121 | 122 | sub match-and-dispatch($msg) { 123 | my $by-bot = $msg.nick.starts-with: ‘Geth’; 124 | # Doc pages 125 | if $by-bot and 126 | $msg.text.match: /^ ‘¦ doc: ’ .* ‘|’ \s+ $<path>=[‘doc/’ < Type Language > .*] $/ { 127 | link-doc-page $msg, $/; 128 | } 129 | # Old design docs 130 | for $msg.text.match: :g, / « $<syn>=[S\d\d] 131 | [ ‘/’ $<subsyn>=[\w+] ]? ‘:’ [ $<line>=[\d+] | $<entry>=[\S+]] 132 | <?{ $<entry> or $<line> ≤ 99999 }> 133 | / { 134 | # unlike the old bot this won't support space-separated 135 | # anchors because of situations like this: 136 | # https://colabti.org/irclogger/irclogger_log/perl6-dev?date=2016-09-22#l87 137 | link-old-design-docs $msg, $_; 138 | } 139 | # GitHub tickets 140 | for $msg.text.match: :g, /:i « $<prefix>=[@(%TICKET-URLS.keys)] 141 | ‘#’ \s* $<id>=[\d**1..6] / { 142 | link-github-ticket $msg, $_; 143 | } 144 | if $by-bot { 145 | for $msg.text.match: :ex, /^ ‘¦ ’ $<prefix>=[\S+] ‘: ’ .*? 146 | <!after ‘created pull request ’> # exclude new PR notifications 147 | <!after ‘Merge pull request ’> # exclude mentions of PR merges 148 | <!after \w> # everything was handled earlier 149 | ‘#’ $<id>=[\d**1..6] » / { 150 | link-github-ticket $msg, $_ 151 | } 152 | } 153 | # RT Tickets 154 | for $msg.text.match: :g, / « RT \s* ‘#’? \s* $<id>=[\d**{5..6}] » / { 155 | link-rt-ticket $msg, $_; 156 | } 157 | # Commits 158 | if not $by-bot { 159 | for $msg.text.match: :g, / <!after ‘:’> [^|\s+] « $<id>=[<xdigit>**{8..40}] » [\s+|$] / { 160 | next if .<id>.comb.unique < 4; # doesn't look like a random commit! 161 | link-commit $msg, $_; 162 | } 163 | } 164 | Nil # This is important! 165 | } 166 | 167 | multi method irc-privmsg-channel($msg where /^ ‘.bots’ \s* $/) { 168 | ‘Docs for all whateverable bots: https://github.com/Raku/whateverable/wiki’ 169 | } 170 | 171 | # TODO Currently there's a chance that it will not respond to some 172 | # direct messages at all, it should *always* say something. 173 | multi method irc-privmsg-channel($msg) { match-and-dispatch $msg } 174 | multi method irc-to-me($msg) { match-and-dispatch $msg } 175 | 176 | sub fetch($prefix, $id) { 177 | my $url = %TICKET-URLS{$prefix} ~ $id; 178 | my %json := curl $url; 179 | my $tags = %json<labels>.map({‘[’ ~ .<name> ~ ‘]’}).join; 180 | 181 | %( 182 | url => %json<html_url>, 183 | title => join(‘ ’, ($tags || Empty), %json<title>), 184 | id => ~%json<number>, 185 | status => %json<state>, 186 | ) 187 | } 188 | 189 | 190 | Linkable.new.selfrun: ‘linkable6’, [ fuzzy-nick(‘linkable6’, 2) ] 191 | 192 | # vim: expandtab shiftwidth=4 ft=perl6 193 | -------------------------------------------------------------------------------- /xbin/Tellable.p6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | # Copyright © 2019-2023 3 | # Aleks-Daniel Jakimenko-Aleksejev <alex.jakimenko@gmail.com> 4 | # 5 | # This program is free software: you can redistribute it and/or modify 6 | # it under the terms of the GNU Affero General Public License as published by 7 | # the Free Software Foundation, either version 3 of the License, or 8 | # (at your option) any later version. 9 | # 10 | # This program is distributed in the hope that it will be useful, 11 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | # GNU Affero General Public License for more details. 14 | # 15 | # You should have received a copy of the GNU Affero General Public License 16 | # along with this program. If not, see <http://www.gnu.org/licenses/>. 17 | 18 | use Whateverable; 19 | use Whateverable::Bits; 20 | use Whateverable::Discordable; 21 | use Whateverable::FootgunDB; 22 | use Whateverable::Userlist; 23 | 24 | use IRC::Client; 25 | use JSON::Fast; 26 | 27 | unit class Tellable does Whateverable does Whateverable::Userlist; 28 | 29 | #| Timeout used for not passing the message if the user 30 | #| reacts immediately 31 | my $heard-timeout = 60 × 10; # should be a few minutes 32 | 33 | my $db-seen = FootgunDB.new: name => ‘tellable/tellable-seen’; 34 | my $db-tell = FootgunDB.new: name => ‘tellable/tellable-tell’; 35 | 36 | method help($msg) { 37 | ‘Like this: .tell AlexDaniel your bot is broken’ 38 | } 39 | 40 | #| normalize nicknames, somewhat 41 | sub normalize-weirdly($nick) { 42 | # We knowingly ignore CASEMAPPING and its bullshit rules. 43 | # Instead we'll do our own crazy stuff in order to DWIM. 44 | # These rules are based on messages that were never delivered. 45 | 46 | # XXX not using s/// because there's a sub s (rakudo/rakudo#3111) 47 | $_ = $nick.fc; 48 | s:!g/‘[m]’$//; # matrix users 49 | s:!g/\W+$//; # garbage at the end 50 | s:!g/^\W+//; # garbage at the beginning 51 | s:g/‘-’//; # hyphens 52 | s:g/‘_’//; # underscores 53 | s:g/(.)$0+/$0/; # accidentally doubled characters 54 | s:g/\d// if S:g/\d//.chars > 4; # remove numbers if we still have letters 55 | .chars ≥ 2 ?? $_ !! $nick; # return original if too much was removed 56 | } 57 | 58 | sub guest-like($nick) { so $nick ~~ /^Guest\d/ } 59 | 60 | #| listen for messages and deliver stuff 61 | multi method irc-privmsg($msg where IRC::Client::Message::Privmsg::Channel) { 62 | return $.NEXT if guest-like $msg.nick; 63 | my $normalized = normalize-weirdly $msg.nick; 64 | $db-seen.read-write: { 65 | .{$normalized} = { 66 | text => $msg.text, 67 | channel => $msg.channel, 68 | timestamp => timestampish, 69 | nick => $msg.nick, 70 | bridged => ($msg.nick ~~ FromDiscord).so, 71 | } 72 | } 73 | my %mail = $db-tell.read; 74 | if %mail{$normalized} { 75 | for %mail{$normalized}.list { 76 | # don't send messages if the person replies real quick 77 | next if .<heard> and timestampish() - DateTime.new(.<timestamp>) ≤ $heard-timeout 78 | and .<channel> eq $msg.channel and not %*ENV<TESTABLE>; 79 | my $text = sprintf ‘%s %s <%s> %s’, .<timestamp channel from text>; 80 | $msg.irc.send-cmd: :server($msg.server), 'PRIVMSG', $msg.channel, 81 | $text but PrettyLink({ “hey {$msg.nick}, you have a message: $_” }); 82 | # you *have* to start the message with “hey” or something 83 | # similar, otherwise two bots can get into an infiloop 84 | sleep 0.3; 85 | } 86 | %mail{$normalized}:delete; 87 | $db-tell.write: %mail; 88 | } 89 | $.NEXT 90 | } 91 | 92 | 93 | #| automatic tell 94 | multi method irc-privmsg-channel($msg where { .Str ~~ m:r/^ \s* $<who>=<.&irc-nick> ‘:’+ \s+ (.*) $/ }) { 95 | my $who = $<who>; 96 | return $.NEXT if self.userlist($msg){$who}; # still on the channel 97 | my $normalized = normalize-weirdly $who; 98 | my %seen := $db-seen.read; 99 | return $.NEXT unless %seen{$normalized}:exists; # haven't seen them talk ever 100 | return $.NEXT if %seen{$normalized}<bridged>; # we don't know status of bridged users 101 | # TODO ↓ this should go through all nicknames on the channel 102 | my $previous-nick = %seen{$normalized}<nick>; 103 | return $.NEXT if self.userlist($msg){$previous-nick}; # previous nickname still on the channel 104 | my $last-seen-duration = DateTime.now(:0timezone) - DateTime.new(%seen{$normalized}<timestamp>); 105 | return $.NEXT if $last-seen-duration ≥ 60×60×24 × 28 × 3; # haven't seen for months 106 | $msg.text = ‘tell ’ ~ $msg.text; 107 | self.irc-to-me: $msg; 108 | } 109 | 110 | #| .seen 111 | multi method irc-privmsg-channel($msg where .args[1] ~~ /^ ‘.seen’ \s+ (.*) /) { 112 | $msg.text = ~$0; 113 | self.irc-to-me: $msg 114 | } 115 | 116 | #| .tell 117 | multi method irc-privmsg-channel($msg where .args[1] ~~ /^ ‘.’[to|tell|ask] \s+ (.*) /) { 118 | $msg.text = ~$0; 119 | self.irc-to-me: $msg 120 | } 121 | 122 | sub did-you-mean-seen($who, %seen) { 123 | did-you-mean $who, %seen.sort(*.value<timestamp>).reverse.map(*.value<nick>), 124 | :max-distance(3) 125 | } 126 | 127 | #| seen 128 | multi method irc-to-me($msg where { .Str ~~ m:r/^ \s* [seen \s+]? 129 | $<who>=<.&irc-nick> <[:,]>* \s* $/ }) { 130 | my $who = ~$<who>; 131 | my %seen := $db-seen.read; 132 | my $entry = %seen{normalize-weirdly $who}; 133 | without $entry { 134 | return ‘I haven't seen any guests around’ if guest-like $who; 135 | return “I haven't seen $who around” 136 | ~ maybe ‘, did you mean %s?’, did-you-mean-seen $who, %seen 137 | } 138 | 139 | # Format CTCP ACTION aka /me 140 | my $said = $entry<text> ~~ /^ \x[01] ‘ACTION ’ <( .* )> \x[01] $/ ?? 141 | “* $entry<nick> $/” !! 142 | “<$entry<nick>> $entry<text>”; 143 | 144 | “I saw $who $entry<timestamp> in $entry<channel>: $said” 145 | } 146 | 147 | #| tell 148 | multi method irc-to-me($msg where { .Str ~~ m:r/^ \s* [[to|tell|ask] \s+]? $<text>=[ 149 | $<who>=<.&irc-nick> <[:,]>* \s+ .* 150 | ]$/ }) { 151 | my $who = ~$<who>; 152 | my $text = ~$<text>; 153 | my $normalized = normalize-weirdly $who; 154 | return ‘Thanks for the message’ if $who eq $msg.server.current-nick; 155 | return ‘I'll pass that message to your doctor’ if $who eq $msg.nick and not %*ENV<TESTABLE>; 156 | my %seen := $db-seen.read; 157 | without %seen{$normalized} { 158 | return ‘Can't pass messages to guests’ if guest-like $who; 159 | return “I haven't seen $who around” 160 | ~ maybe ‘, did you mean %s?’, did-you-mean-seen $who, %seen 161 | } 162 | # TODO ↓ this should go through all nicknames on the channel 163 | my $previous-nick = %seen{$normalized}<nick>; 164 | my $heard = so any self.userlist($msg){$who, $previous-nick}; 165 | $db-tell.read-write: { 166 | .{$normalized}.push: { 167 | text => $text, 168 | channel => $msg.channel, 169 | timestamp => timestampish, 170 | from => $msg.nick, 171 | to => $who, 172 | heard => $heard, 173 | } 174 | } 175 | “I'll pass your message to {%seen{$normalized}<nick>}” 176 | } 177 | 178 | 179 | { 180 | # Renormalize on startup in case the rules were updated 181 | $db-tell.write: $db-tell.read.values».list.flat.classify: { 182 | normalize-weirdly .<to> 183 | }; 184 | my %seens = %(); 185 | for $db-seen.read.values { 186 | my $normalized = normalize-weirdly .<nick>; 187 | if %seens{$normalized}:!exists or DateTime.new(%seens{$normalized}<timestamp>) < DateTime.new(.<timestamp>) { 188 | %seens{$normalized} = $_; 189 | } 190 | } 191 | $db-seen.write: %seens; 192 | } 193 | 194 | Tellable.new.selfrun: ‘tellable6’, [/ [to|tell|ask|seen] 6? <before ‘:’> /, 195 | fuzzy-nick(‘tellable6’, 1)]; 196 | 197 | # vim: expandtab shiftwidth=4 ft=perl6 198 | -------------------------------------------------------------------------------- /lib/Whateverable/Processing.pm6: -------------------------------------------------------------------------------- 1 | # Copyright © 2016-2023 2 | # Aleks-Daniel Jakimenko-Aleksejev <alex.jakimenko@gmail.com> 3 | # Copyright © 2016 4 | # Daniel Green <ddgreen@gmail.com> 5 | # 6 | # This program is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU Affero General Public License as published by 8 | # the Free Software Foundation, either version 3 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # This program is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU Affero General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU Affero General Public License 17 | # along with this program. If not, see <http://www.gnu.org/licenses/>. 18 | 19 | use JSON::Fast; 20 | use HTTP::UserAgent; 21 | 22 | use Whateverable::Bits; 23 | use Whateverable::Builds; 24 | use Whateverable::Config; 25 | use Whateverable::Running; 26 | 27 | unit module Whateverable::Processing; 28 | 29 | #↓ Runs $filename using some build on $full-commit and performs 30 | #↓ some basic output formatting. 31 | sub subprocess-commit($commit, $filename, $full-commit, :%ENV) is export { 32 | # TODO $commit unused 33 | return ‘No build for this commit’ unless build-exists $full-commit; 34 | 35 | $_ = run-snippet $full-commit, $filename, :%ENV; # actually run the code 36 | # numbers less than zero indicate other weird failures ↓ 37 | return “Cannot test this commit ($_<output>)” if .<signal> < 0; 38 | my $output = .<output>; 39 | $output ~= “ «exit code = $_<exit-code>»” if .<exit-code> ≠ 0; 40 | $output ~= “ «exit signal = {Signal($_<signal>)} ($_<signal>)»” if .<signal> ≠ 0; 41 | $output 42 | } 43 | 44 | #| Transform a revision into `output => short SHA` pair 45 | sub process-commit($commit, $filename, :%ENV) is export { 46 | # convert to real ids so we can look up the builds 47 | my $full-commit = to-full-commit $commit; 48 | my $short-commit = get-short-commit $commit; 49 | $short-commit ~= “({get-short-commit $full-commit})” if $commit eq ‘HEAD’; 50 | 51 | without $full-commit { 52 | return $short-commit R=> ‘Cannot find this revision (did you mean “’ ~ 53 | get-short-commit(get-similar $commit, <HEAD v6.c releases all>) ~ 54 | ‘”?)’ 55 | } 56 | $short-commit R=> subprocess-commit $commit, $filename, $full-commit, :%ENV; 57 | } 58 | 59 | #| Runs process-commit on each commit and saves the 60 | #| results in a given array and hash 61 | sub proccess-and-group-commits(@outputs, # unlike %shas this is ordered 62 | %shas, # { output => [sha, sha, …], … } 63 | $file, 64 | *@commits, 65 | :$intermingle=True, :$prepend=False, 66 | :$start-time, :$time-limit, 67 | :%ENV=%*ENV) is export { 68 | for @commits.map: { process-commit $_, $file, :%ENV } { 69 | if $start-time && $time-limit && now - $start-time > $time-limit { # bail out if needed 70 | grumble “«hit the total time limit of $time-limit seconds»” 71 | } 72 | my $push-needed = $intermingle 73 | ?? (%shas{.key}:!exists) 74 | !! !@outputs || @outputs.tail ne .key; 75 | @outputs.push: .key if $push-needed; 76 | if $prepend { 77 | %shas{.key}.prepend: .value; 78 | } else { 79 | %shas{.key}.append: .value; 80 | } 81 | } 82 | } 83 | 84 | #| Takes the array and hash produced by `proccess-and-group-commits` 85 | #| and turns it into a beautiful gist (or a short reply). 86 | #| Note that it can list the same commit set more than once if you're 87 | #| not using intermingle feature in proccess-and-group-commits. 88 | #| Arguably it's a feature, but please judge yourself. 89 | sub commit-groups-to-gisted-reply(@outputs, %shas, $config) is export { 90 | my $short-str = @outputs == 1 && %shas{@outputs[0]} > 3 && $config.chars < 20 91 | ?? “¦{$config} ({+%shas{@outputs[0]}} commits): «{@outputs[0]}»” 92 | !! ‘¦’ ~ @outputs.map({ “{%shas{$_}.join: ‘,’}: «$_»” }).join: ‘ ¦’; 93 | 94 | my $long-str = ‘¦’ ~ @outputs.map({ “«{limited-join %shas{$_}}»:\n$_” }).join: “\n¦”; 95 | $short-str but ProperStr($long-str); 96 | } 97 | 98 | #↓ Substitutes some characters in $code if it looks like code, or 99 | #↓ fetches code from a url if $code looks like one. 100 | sub process-code($code is copy, $msg) is export { 101 | $code ~~ m{^ ( ‘http’ s? ‘://’ \S+ ) } 102 | ?? process-gist(~$0, $msg) // write-code process-url(~$0, $msg) 103 | !! write-code $code.subst: :g, ‘␤’, “\n” 104 | } 105 | 106 | #↓ Slurps contents of some page as if it was a raw link to code. 107 | sub process-url($url, $msg) is export { 108 | my $ua = HTTP::UserAgent.new: :useragent<Whateverable>; 109 | my $response; 110 | try { 111 | $response = $ua.get: $url; 112 | CATCH { 113 | grumble ‘It looks like a URL, but for some reason I cannot download it’ 114 | ~ “ ({.message})” 115 | } 116 | } 117 | if not $response.is-success { 118 | grumble ‘It looks like a URL, but for some reason I cannot download it’ 119 | ~ “ (HTTP status line is {$response.status-line})” 120 | } 121 | if not $response.content-type.contains: ‘text/plain’ | ‘perl’ { 122 | grumble “It looks like a URL, but mime type is ‘{$response.content-type}’” 123 | ~ ‘ while I was expecting something with ‘text/plain’ or ‘perl’’ 124 | ~ ‘ in it. I can only understand raw links, sorry.’ 125 | } 126 | 127 | my $body = $response.decoded-content; 128 | .reply: ‘Successfully fetched the code from the provided URL’ with $msg; 129 | sleep 0.02; # https://github.com/Raku/whateverable/issues/163 130 | $body 131 | } 132 | 133 | #↓ Handles github gists by placing the files into `sandbox/` directory. 134 | #↓ Returns path to the main file (which was detected heuristically). 135 | sub process-gist($url, $msg) is export { 136 | return unless $url ~~ 137 | /^ ‘https://gist.github.com/’<[a..zA..Z-]>+‘/’(<.xdigit>**32) $/; 138 | 139 | my $gist-id = ~$0; 140 | my $api-url = ‘https://api.github.com/gists/’ ~ $gist-id; 141 | 142 | my $ua = HTTP::UserAgent.new: :useragent<Whateverable>; 143 | my $response; 144 | try { 145 | $response = $ua.get: $api-url; 146 | CATCH { 147 | grumble “Cannot fetch data from GitHub API ({.message})” 148 | } 149 | } 150 | if not $response.is-success { 151 | grumble ‘Cannot fetch data from GitHub API’ 152 | ~ “ (HTTP status line is {$response.status-line})” 153 | } 154 | 155 | my %scores; # used to determine the main file to execute 156 | 157 | my %data = from-json $response.decoded-content; 158 | grumble ‘Refusing to handle truncated gist’ if %data<truncated>; 159 | 160 | sub path($filename) { “$CONFIG<sandbox-path>/$filename”.IO } 161 | 162 | for %data<files>.values { 163 | grumble ‘Invalid filename returned’ if .<filename>.contains: ‘/’|“\0”; 164 | 165 | my $score = 0; # for heuristics 166 | $score += 50 if .<language> && .<language> eq ‘Perl 6’; 167 | $score -= 20 if .<filename>.ends-with: ‘.pm6’; 168 | $score -= 10 if .<filename>.ends-with: ‘.t’; 169 | $score += 40 if .<content>.contains: ‘ MAIN’; 170 | 171 | my IO $path = path .<filename>; 172 | if .<size> ≥ 10_000_000 { 173 | $score -= 300; 174 | grumble ‘Refusing to handle files larger that 10 MB’; 175 | } 176 | if .<truncated> { 177 | $score -= 100; 178 | grumble ‘Can't handle truncated files yet’; # TODO? 179 | } 180 | 181 | mkdir $path.parent; 182 | spurt $path, .<content>; 183 | 184 | if .<filename>.ends-with: ‘.md’ | ‘.markdown’ { 185 | for ‘raku’, ‘perl6’, ‘perl’, ‘’ -> $type { 186 | if .<content> ~~ /‘```’ $type \s* \n ~ ‘```’ (.+?) / { 187 | .<content> = ~$0; 188 | #↓ XXX resave the file with just the code. Total hack but it works 189 | spurt $path, .<content>; 190 | $score += 3; 191 | last 192 | } 193 | } 194 | } 195 | 196 | %scores.push: .<filename> => $score 197 | } 198 | 199 | my $main-file = %scores.max(*.value).key; 200 | if $msg and %scores > 1 { 201 | $msg.reply: “Using file “$main-file” as a main file, other files are placed in “$CONFIG<sandbox-path>”” 202 | } 203 | path $main-file 204 | } 205 | 206 | # vim: expandtab shiftwidth=4 ft=perl6 207 | -------------------------------------------------------------------------------- /xbin/Benchable.p6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | # Copyright © 2016-2023 3 | # Aleks-Daniel Jakimenko-Aleksejev <alex.jakimenko@gmail.com> 4 | # Daniel Green <ddgreen@gmail.com> 5 | # 6 | # This program is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU Affero General Public License as published by 8 | # the Free Software Foundation, either version 3 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # This program is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU Affero General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU Affero General Public License 17 | # along with this program. If not, see <http://www.gnu.org/licenses/>. 18 | 19 | use Whateverable; 20 | use Whateverable::Bits; 21 | use Whateverable::Builds; 22 | use Whateverable::Config; 23 | use Whateverable::Output; 24 | use Whateverable::Processing; 25 | use Whateverable::Running; 26 | 27 | use File::Directory::Tree; 28 | use IRC::Client; 29 | use SVG::Plot; 30 | use SVG; 31 | use Stats; 32 | 33 | unit class Benchable does Whateverable; 34 | 35 | constant TOTAL-TIME = 60 × 4; 36 | constant ITERATIONS = 5; 37 | constant LIB-DIR = ‘data’.IO.absolute; 38 | 39 | method help($msg) { 40 | ‘Like this: ’ ~ $msg.server.current-nick 41 | ~ ‘: f583f22,HEAD my $a = ‘a’ x 2¹⁶; for ^1000 {my $b = $a.chop($_)}’ 42 | } 43 | 44 | multi method benchmark-code($full-commit, $filename) { 45 | my @times; 46 | my %stats; 47 | for ^ITERATIONS { 48 | my $result = run-snippet $full-commit, $filename; 49 | if $result<exit-code> ≠ 0 { 50 | %stats<err> = “«run failed, exit code = $result<exit-code>, exit signal = $result<signal>»”; 51 | return %stats 52 | } 53 | @times.push: sprintf ‘%.4f’, $result<time> 54 | } 55 | 56 | # TODO min/max/mean/sd are working on stringified numbers? Is that what we want? 57 | %stats<min> = min @times; 58 | %stats<max> = max @times; 59 | %stats<mean> = mean @times; 60 | %stats<stddev> = sd @times; 61 | 62 | %stats 63 | } 64 | 65 | multi method benchmark-code($full-commit-hash, @code) { 66 | my $file = write-code ‘use Bench; my %subs = ’ 67 | ~ @code.kv.map({ $^k => “ => sub \{ $^v \} ” }).join(‘,’) ~ ‘;’ 68 | ~ ‘ my $b = Bench.new; $b.cmpthese(’ ~ ITERATIONS × 2 ~ ‘, %subs)’; 69 | LEAVE { unlink $_ with $file } 70 | my %ENV = %*ENV; 71 | %ENV<PERL6LIB> = “{LIB-DIR}/perl6-bench/lib,{LIB-DIR}/Perl6-Text--Table--Simple/lib”; 72 | run-snippet($full-commit-hash, $file, :%ENV)<output> 73 | } 74 | 75 | multi method irc-to-me($msg where /^ \s* $<config>=([:i compare \s]? <.&commit-list>) \s+ $<code>=.+ /) { 76 | my ($value, %additional-files) = self.process: $msg, ~$<config>, ~$<code>; 77 | return unless $value; 78 | $value but FileStore(%additional-files) 79 | } 80 | 81 | method process($msg, $config, $code) { 82 | my $start-time = now; 83 | my $old-dir = $*CWD; 84 | my @commits = get-commits $config; 85 | my $file = process-code $code, $msg; 86 | LEAVE .unlink with $file; 87 | 88 | my %graph; 89 | my %times; 90 | my $actually-tested = 0; 91 | for @commits -> $commit { 92 | FIRST my $once = ‘Give me a ping, Vasili. One ping only, please.’; 93 | if now - $start-time > TOTAL-TIME { 94 | grumble “«hit the total time limit of {TOTAL-TIME} seconds»” 95 | } 96 | # convert to real ids so we can look up the builds 97 | my $full-commit = to-full-commit $commit; 98 | my $short-commit = get-short-commit $commit; 99 | if not defined $full-commit { 100 | my @options = <HEAD v6.c releases all>; 101 | %times{$short-commit}<err> = ‘Cannot find this revision’ 102 | ~ “ (did you mean “{get-short-commit get-similar $commit, @options}”?)” 103 | # TODO why $commit is a match here when using compare? 104 | } elsif not build-exists $full-commit { 105 | %times{$short-commit}<err> = ‘No build for this commit’ 106 | } else { # actually run the code 107 | with $once { 108 | my $c = +@commits; 109 | my $s = $c == 1 ?? ‘’ !! ‘s’; 110 | reply $msg, “starting to benchmark the $c given commit$s” 111 | } 112 | my $arg = $config ~~ /:i compare / ?? $code.split: ‘|||’ !! $file; 113 | %times{$short-commit} = self.benchmark-code: $full-commit, $arg; 114 | $actually-tested++ 115 | } 116 | } 117 | 118 | my $num-commits = +@commits; 119 | 120 | # for these config options, check if there are any large speed differences between two commits and if so, 121 | # recursively find the commit in the middle until there are either no more large speed differences or no 122 | # more commits inbetween (i.e., the next commit is the exact one that caused the difference) 123 | if $actually-tested > 1 and 124 | ($config ~~ /:i ^ [ releases | v? 6 \.? c | all ] $ / or $config.contains: ‘,’) { 125 | if $num-commits < ITERATIONS { 126 | my @prelim-commits = @commits.map({ get-short-commit $_ }); 127 | reply $msg, ‘¦’ ~ @prelim-commits.map({ “$_: ” ~ ‘«’ ~ (%times{$_}<err> // %times{$_}<min> // %times{$_}) ~ ‘»’ }).join: ‘ ¦’; 128 | } 129 | sleep 0.05; # to prevent messages from being reordered 130 | 131 | Z: loop (my $x = 0; $x < @commits - 1; $x++) { 132 | if now - $start-time > TOTAL-TIME { 133 | grumble “«hit the total time limit of {TOTAL-TIME} seconds»”; 134 | last Z; 135 | } 136 | 137 | next unless %times{@commits[$x]}:exists and %times{@commits[$x + 1]}:exists; # the commits have to have been run at all 138 | next if %times{@commits[$x]}<err>:exists or %times{@commits[$x + 1]}<err>:exists; # and without error 139 | if abs(%times{@commits[$x]}<min> - %times{@commits[$x + 1]}<min>) ≥ %times{@commits[$x]}<min> × 0.1 { 140 | once reply $msg, ‘benchmarked the given commits and found a performance difference > 10%, now trying to bisect’; 141 | my $result = get-output :cwd($CONFIG<projects><rakudo-moar><repo-path>), ‘git’, ‘rev-list’, 142 | ‘--bisect’, ‘--no-merges’, 143 | @commits[$x] ~ ‘^..’ ~ @commits[$x + 1]; 144 | my $new-commit = $result<output>; 145 | if $result<exit-code> == 0 and defined $new-commit and $new-commit ne ‘’ { 146 | my $short-commit = get-short-commit $new-commit; 147 | if not build-exists $new-commit { 148 | %times{$short-commit}<err> = ‘No build for this commit’ 149 | } elsif %times{$short-commit}:!exists and $short-commit ne @commits[$x] and $short-commit ne @commits[$x + 1] { # actually run the code 150 | %times{$short-commit} = self.benchmark-code: $new-commit, $file; 151 | @commits.splice: $x + 1, 0, $short-commit; 152 | redo Z 153 | } 154 | } 155 | } 156 | } 157 | } 158 | 159 | @commits .= map: { get-short-commit $_ }; 160 | 161 | if @commits ≥ ITERATIONS { 162 | my $pfilename = ‘plot.svg’; 163 | my $title = “$config $code”.trans: ｢"｣ => ｢\"｣; 164 | my @valid-commits = @commits.grep: { %times{$_}<err>:!exists }; 165 | my @values = @valid-commits.map: { %times{$_}<min> }; 166 | my @labels = @valid-commits.map: { “$_ ({ .<mean max stddev>.map({ sprintf “%.2f”, $_ }).join: ‘,’ with %times{$_} })” }; 167 | 168 | my $plot = SVG::Plot.new( 169 | :1000width, 170 | :800height, 171 | :0min-y-axis, 172 | :$title, 173 | values => (@values,), 174 | :@labels, 175 | background => ‘white’, 176 | ).plot(:lines); 177 | 178 | %graph{$pfilename} = SVG.serialize: $plot 179 | } 180 | 181 | my $short-str = ‘¦’ ~ @commits.map({ “$_: ” ~ ‘«’ ~ (%times{$_}<err> // %times{$_}<min> // %times{$_}) ~ ‘»’ }).join: ‘ ¦’; 182 | my $long-str = ‘¦’ ~ @commits.map({ “$_: ” ~ ‘«’ ~ (%times{$_}<err> // %times{$_}<min> // %times{$_}) ~ ‘»’ }).join: “\n¦”; 183 | 184 | if $num-commits < @commits or $config ~~ /:i compare / { # new commits were added while bisecting 185 | return $short-str but ProperStr($long-str), %graph 186 | } else { 187 | return ‘No new data found’ 188 | } 189 | } 190 | 191 | 192 | Benchable.new.selfrun: ‘benchable6’, [ / bench6? <before ‘:’> /, 193 | fuzzy-nick(‘benchable6’, 2) ]; 194 | 195 | # vim: expandtab shiftwidth=4 ft=perl6 196 | -------------------------------------------------------------------------------- /xbin/Unicodable.p6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | # Copyright © 2016-2023 3 | # Aleks-Daniel Jakimenko-Aleksejev <alex.jakimenko@gmail.com> 4 | # Copyright © 2016 5 | # Daniel Green <ddgreen@gmail.com> 6 | # 7 | # This program is free software: you can redistribute it and/or modify 8 | # it under the terms of the GNU Affero General Public License as published by 9 | # the Free Software Foundation, either version 3 of the License, or 10 | # (at your option) any later version. 11 | # 12 | # This program is distributed in the hope that it will be useful, 13 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 14 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 | # GNU Affero General Public License for more details. 16 | # 17 | # You should have received a copy of the GNU Affero General Public License 18 | # along with this program. If not, see <http://www.gnu.org/licenses/>. 19 | 20 | use Whateverable; 21 | use Whateverable::Bits; 22 | use Whateverable::Builds; 23 | use Whateverable::Processing; 24 | use Whateverable::Running; 25 | use Whateverable::Uniprops; 26 | use Whateverable::Userlist; 27 | 28 | use IRC::Client; 29 | 30 | unit class Unicodable does Whateverable does Whateverable::Userlist; 31 | 32 | constant MESSAGE-LIMIT = 3; 33 | constant $LIMIT = 5_000; 34 | constant $PREVIEW-LIMIT = 50; 35 | 36 | method help($msg) { 37 | ‘Just type any Unicode character or part of a character name. Alternatively, you can also provide a code snippet.’ 38 | } 39 | 40 | multi method irc-to-me($msg) { 41 | if $msg.args[1].starts-with: ‘propdump:’ | ‘unidump:’ { 42 | return self.propdump: $msg, $msg.text 43 | } 44 | return self.process: $msg, $msg.text if $msg.args[1] !~~ /^ ‘.u’ \s /; 45 | self.make-believe: $msg, <yoleaux yoleaux2>, { 46 | self.process: $msg, $msg.text 47 | } 48 | } 49 | 50 | multi method irc-privmsg-channel($msg where .args[1] ~~ /^ ‘.u’ \s (.*) /) { 51 | $msg.text = ~$0; 52 | self.irc-to-me: $msg 53 | } 54 | 55 | multi method codepointify(Int $ord ) { $ord.fmt: ‘U+%04X’ } 56 | multi method codepointify(Str $char) { $char.ords».fmt(‘U+%04X’).join: ‘, ’ } 57 | 58 | method sanify($ord) { 59 | my $char; 60 | try { 61 | $char = $ord.chr; 62 | CATCH { return “{self.codepointify($ord)} (invalid codepoint)” } 63 | } 64 | try { 65 | $char.encode; 66 | CATCH { return ‘unencodable character’ } 67 | } 68 | my $gcb = $ord.uniprop(‘Grapheme_Cluster_Break’); 69 | return “\c[NBSP]” ~ $char if $gcb eq ‘Extend’ | ‘ZWJ’; 70 | return $char ~ “\c[NBSP]” if $gcb eq ‘Prepend’; 71 | return ‘control character’ if $gcb eq ‘Control’ | ‘CR’ | ‘LF’; 72 | $char 73 | } 74 | 75 | method get-description($ord) { 76 | my $sane = self.sanify: $ord; 77 | return $sane if $sane.ends-with: ‘(invalid codepoint)’; 78 | sprintf “%s %s [%s] (%s)”, 79 | self.codepointify($ord), $ord.uniname, 80 | $ord.uniprop, $sane 81 | } 82 | 83 | method get-preview(@all) { 84 | return ‘’ if @all > $PREVIEW-LIMIT; 85 | return ‘’ if @all».uniprop(‘Grapheme_Cluster_Break’).any eq 86 | ‘Control’ | ‘CR’ | ‘LF’ | ‘Extend’ | ‘Prepend’ | ‘ZWJ’; 87 | my $preview = @all».chr.join; 88 | return ‘’ if @all !~~ $preview.comb».ord; # round trip test 89 | “ ($preview)” 90 | } 91 | 92 | method compose-gist(@all) { 93 | my $gist = @all.map({self.get-description: $_}).join: “\n”; 94 | my $link-msg = { “{+@all} characters in total{self.get-preview: @all}: $_” }; 95 | (‘’ but ProperStr($gist)) but PrettyLink($link-msg) 96 | } 97 | 98 | method from-numerics($query) { 99 | $query ~~ m:ignoremark/^ 100 | :i \s* 101 | [ 102 | [ | [｢\U｣ | ‘u’ (.) <?{ $0[*-1].Str.uniname.match: /PLUS.*SIGN/ }> ] 103 | | [ <:Nd> & <:Numeric_Value(0)> ] ‘x’ # TODO is it fixed now? … What exactly? 104 | ] 105 | $<digit>=<:HexDigit>+ 106 | ]+ %% \s+ 107 | $/; 108 | return () without $<digit>; 109 | $<digit>.map: { parse-base ~$_, 16 } 110 | } 111 | 112 | method process($msg, $query is copy) { 113 | my $file = process-code $query, $msg; 114 | LEAVE .unlink with $file; 115 | 116 | my $file-contents = $file.slurp; 117 | if $file-contents ne $query { 118 | $query = $file-contents # fetched from URL 119 | } elsif not $msg.args[1].match: /^ ‘.u’ \s / { 120 | $query = ~$0 if $msg.args[1] ~~ / <[,:]> \s (.*) / # preserve leading spaces 121 | } 122 | my @all; 123 | 124 | my @numerics = self.from-numerics: $query; 125 | if @numerics { 126 | for @numerics { 127 | @all.push: $_; 128 | reply $msg, self.get-description: $_ if @all [<] MESSAGE-LIMIT 129 | } 130 | } elsif $query.trim-trailing ~~ /^ <+[a..zA..Z] +[0..9] +[\-\ ]>+ $ && .*? \S / { 131 | my @words; 132 | my @props; 133 | for $query.words { 134 | if /^ <[A..Z]> <[a..z]> $/ { 135 | @props.push: $_ 136 | } else { 137 | @words.push: .uc 138 | } 139 | } 140 | # ↓ do not touch these three lines 141 | my $sieve = 0..0x10FFFF; 142 | for @words -> $word { $sieve .= grep({uniname($_).contains($word)}) }; 143 | for @props -> $prop { $sieve .= grep({uniprop($_) eq $prop}) }; 144 | 145 | for @$sieve { 146 | @all.push: $_; 147 | grumble “Cowardly refusing to gist more than $LIMIT lines” if @all > $LIMIT; 148 | reply $msg, self.get-description: $_ if @all [<] MESSAGE-LIMIT 149 | } 150 | } elsif $query.starts-with: ‘/’ { 151 | grumble ‘Regexes are not supported yet, sorry! Try code blocks instead’ 152 | } elsif $query.starts-with: ‘{’ { 153 | my $full-commit = to-full-commit ‘HEAD’; 154 | my $output = ‘’; 155 | my $file = write-code “say join “\c[31]”, (0..0x10FFFF).grep:\n” ~ $query; 156 | LEAVE unlink $_ with $file; 157 | 158 | die ‘No build for the last commit. Oops!’ unless build-exists $full-commit; 159 | 160 | # actually run the code 161 | my $result = run-snippet $full-commit, $file; 162 | $output = $result<output>; 163 | # numbers less than zero indicate other weird failures ↓ 164 | grumble “Something went wrong ($output)” if $result<signal> < 0; 165 | 166 | $output ~= “ «exit code = $result<exit-code>»” if $result<exit-code> ≠ 0; 167 | $output ~= “ «exit signal = {Signal($result<signal>)} ($result<signal>)»” if $result<signal> ≠ 0; 168 | return $output if $result<exit-code> ≠ 0 or $result<signal> ≠ 0; 169 | 170 | for $output.split: “\c[31]”, :skip-empty { 171 | @all.push: +$_; 172 | grumble “Cowardly refusing to gist more than $LIMIT lines” if @all > $LIMIT; 173 | reply $msg, self.get-description: +$_ if @all [<] MESSAGE-LIMIT 174 | } 175 | } else { 176 | for $query.comb».ords.flat { 177 | @all.push: $_; 178 | grumble “Cowardly refusing to gist more than $LIMIT lines” if @all > $LIMIT; 179 | if @all [<] MESSAGE-LIMIT { 180 | sleep 0.05 if @all > 1; # let's try to keep it in order 181 | reply $msg, self.get-description: $_ 182 | } 183 | } 184 | } 185 | 186 | return self.get-description: @all[*-1] if @all == MESSAGE-LIMIT; 187 | return self.compose-gist: @all if @all > MESSAGE-LIMIT; 188 | return ‘Found nothing!’ unless @all; 189 | return 190 | } 191 | 192 | method propdump($msg, $query) { 193 | my $answer = ‘’; 194 | my @numerics = self.from-numerics: $query; 195 | my @query = @numerics || $query.comb».ords.flat; 196 | my &escape = *.trans: (‘|’,) => (‘|’,); 197 | for @prop-table -> $category { 198 | $answer ~= sprintf “\n### %s\n”, $category.key; 199 | $answer ~= sprintf ‘| %-55s |’, ‘Property names’; 200 | $answer ~= .fmt: ‘ %-25s |’ for @query.map: -> $char { “Value: {&escape(self.sanify: $char)}” }; 201 | $answer ~= “\n”; 202 | $answer ~= “|{‘-’ x 57}|”; 203 | $answer ~= “{‘-’ x 27}|” x @query; 204 | $answer ~= “\n”; 205 | for $category.value -> $cat { 206 | my @props = @query.map: *.uniprop: $cat[0]; 207 | my $bold = ([eq] @props) ?? ｢｣ !! ｢**｣; 208 | $answer ~= ($bold ~ $cat.join(‘, ’) ~ $bold).fmt: ‘| %-55s |’; 209 | $answer ~= &escape(.comb».ords.flat.map({self.sanify: $_}).join).fmt: ‘ %-25s |’ for @props; 210 | $answer ~= “\n”; 211 | } 212 | } 213 | ‘’ but FileStore({ ‘result.md’ => $answer }) 214 | } 215 | 216 | 217 | %*BOT-ENV<timeout> = 30; 218 | 219 | Unicodable.new.selfrun: ‘unicodable6’, [/ u[ni]?6? <before ‘:’> /, ‘propdump’, ‘unidump’, 220 | fuzzy-nick(‘unicodable6’, 2)]; 221 | 222 | # vim: expandtab shiftwidth=4 ft=perl6 223 | -------------------------------------------------------------------------------- /xt/benchable.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | BEGIN %*ENV<PERL6_TEST_DIE_ON_FAIL> = 1; 3 | %*ENV<TESTABLE> = 1; 4 | 5 | use lib <lib xt/lib>; 6 | use Test; 7 | use Testable; 8 | 9 | my $t = Testable.new: bot => ‘Benchable’; 10 | 11 | $t.common-tests: help => “Like this: {$t.bot-nick}: f583f22,HEAD ” 12 | ~ ｢my $a = ‘a’ x 2¹⁶; for ^1000 {my $b = $a.chop($_)}｣; 13 | 14 | $t.shortcut-tests: <bench: bench6:>, 15 | <bench bench, bench6 bench6, b b, b:>; 16 | 17 | $t.test(‘fallback’, 18 | “{$t.bot-nick}: wazzup?”, 19 | “{$t.our-nick}, I cannot recognize this command. See wiki for some examples: https://github.com/Raku/whateverable/wiki/Benchable”); 20 | 21 | # Basics 22 | 23 | $t.test(‘basic “nick:” query’, 24 | “{$t.bot-nick}: HEAD say ‘hello’”, 25 | /^ <me($t)>‘, starting to benchmark the ’ \d+ ‘ given commit’ ‘s’? $/, 26 | /^ <me($t)>‘, ¦HEAD: «’ \d+\.\d+ ‘»’ $/); 27 | 28 | $t.test(‘basic “nick,” query’, 29 | “{$t.bot-nick}, HEAD say ‘hello’”, 30 | /^ <me($t)>‘, starting to benchmark the ’ \d+ ‘ given commit’ ‘s’? $/, 31 | /^ <me($t)>‘, ¦HEAD: «’ \d+\.\d+ ‘»’ $/); 32 | 33 | $t.test(‘“bench:” shortcut’, 34 | ‘bench: HEAD say ‘hello’’, 35 | /^ <me($t)>‘, starting to benchmark the ’ \d+ ‘ given commit’ ‘s’? $/, 36 | /^ <me($t)>‘, ¦HEAD: «’ \d+\.\d+ ‘»’ $/); 37 | 38 | $t.test(‘“bench6:” shortcut’, 39 | ‘bench6: HEAD say ‘hello’’, 40 | /^ <me($t)>‘, starting to benchmark the ’ \d+ ‘ given commit’ ‘s’? $/, 41 | /^ <me($t)>‘, ¦HEAD: «’ \d+\.\d+ ‘»’ $/); 42 | 43 | $t.test(‘“bench” shortcut does not work’, 44 | ‘bench HEAD say ‘hello’’); 45 | 46 | $t.test(‘“bench6” shortcut does not work’, 47 | ‘bench6 HEAD say ‘hello’’); 48 | 49 | $t.test(‘specific commit’, 50 | ‘bench: f583f22 say $*PERL.compiler.version’, 51 | /^ <me($t)>‘, starting to benchmark the ’ \d+ ‘ given commit’ ‘s’? $/, 52 | /^ <me($t)>‘, ¦f583f22: «’ \d+\.\d+ ‘»’ $/); 53 | 54 | $t.test(‘the benchmark time makes sense’, 55 | ‘bench: HEAD sleep 2’, 56 | /^ <me($t)>‘, starting to benchmark the ’ \d+ ‘ given commit’ ‘s’? $/, 57 | /^ <me($t)>‘, ¦HEAD: «’ (\d+)\.\d+ <?{ $0 ≥ 2 }> ‘»’ $/, 58 | :30timeout); 59 | 60 | $t.test(‘“compare” query’, 61 | ‘bench: compare HEAD say ‘hi’ ||| say ‘bye’’, 62 | /^ <me($t)>‘, starting to benchmark the ’ \d+ ‘ given commit’ ‘s’? $/, 63 | “{$t.our-nick}, https://whatever.able/fakeupload”); 64 | 65 | # Ranges and multiple commits 66 | 67 | $t.test(‘“releases” query’, 68 | ‘bench: releases say $*PERL’, 69 | /^ <me($t)>‘, starting to benchmark the ’ \d+ ‘ given commit’ ‘s’? $/, 70 | “{$t.our-nick}, benchmarked the given commits, now zooming in on performance differences”, 71 | “{$t.our-nick}, https://whatever.able/fakeupload”, 72 | :240timeout); 73 | 74 | $t.test(‘“v6c” query’, 75 | ‘bench: v6c say $*PERL’, 76 | /^ <me($t)>‘, starting to benchmark the ’ \d+ ‘ given commit’ ‘s’? $/, 77 | “{$t.our-nick}, benchmarked the given commits, now zooming in on performance differences”, 78 | “{$t.our-nick}, https://whatever.able/fakeupload”, 79 | :240timeout); 80 | 81 | $t.test(‘multiple commits separated by comma (three consecutive commits, so zooming in on performance differences will not create a graph’, 82 | “bench: b1f77c8,87bba04,79bb867 say ‘hello’”, 83 | /^ <me($t)>‘, starting to benchmark the ’ \d+ ‘ given commit’ ‘s’? $/, 84 | “{$t.our-nick}, benchmarked the given commits, now zooming in on performance differences”, 85 | /^ <me($t)>‘, ¦b1f77c8: «’ \d+\.\d+ ‘» ¦87bba04: «’ \d+\.\d+ ‘» ¦79bb867: «’ \d+\.\d+ ‘»’ $/, 86 | :20timeout); 87 | 88 | $t.test(‘commit~num syntax’, 89 | ‘bench: 2016.10~1 say $*PERL.compiler.version’, 90 | /^ <me($t)>‘, starting to benchmark the ’ \d+ ‘ given commit’ ‘s’? $/, 91 | /^ <me($t)>‘, ¦2016.10~1: «’ \d+\.\d+ ‘»’ $/); 92 | 93 | $t.test(‘commit^^^ syntax’, 94 | ‘bench: 2016.10^^ say $*PERL.compiler.version’, 95 | /^ <me($t)>‘, starting to benchmark the ’ \d+ ‘ given commit’ ‘s’? $/, 96 | /^ <me($t)>‘, ¦2016.10^^: «’ \d+\.\d+ ‘»’ $/); 97 | 98 | $t.test(‘commit..commit range syntax’, 99 | ‘bench: 79bb867..b1f77c8 say ‘a’ x 9999999999999999999’, 100 | /^ <me($t)>‘, starting to benchmark the ’ \d+ ‘ given commit’ ‘s’? $/, 101 | /^ <me($t)>‘, ¦79bb867: «’ \d+\.\d+ ‘» ¦87bba04: «’ \d+\.\d+ ‘» ¦b1f77c8: «’ \d+\.\d+ ‘»’ $/, 102 | :20timeout); 103 | 104 | # URLs 105 | 106 | $t.test(‘fetching code from urls’, 107 | ‘bench: HEAD https://gist.githubusercontent.com/AlexDaniel/147bfa34b5a1b7d1ebc50ddc32f95f86/raw/9e90da9f0d95ae8c1c3bae24313fb10a7b766595/test.p6’, 108 | “{$t.our-nick}, Successfully fetched the code from the provided URL”, 109 | /^ <me($t)>‘, starting to benchmark the ’ \d+ ‘ given commit’ ‘s’? $/, 110 | /^ <me($t)>‘, ¦HEAD: «’ \d+\.\d+ ‘»’ $/); 111 | 112 | $t.test(‘comment after a url’, 113 | ‘bench: HEAD https://gist.githubusercontent.com/AlexDaniel/147bfa34b5a1b7d1ebc50ddc32f95f86/raw/9e90da9f0d95ae8c1c3bae24313fb10a7b766595/test.p6 # this is a comment’, 114 | “{$t.our-nick}, Successfully fetched the code from the provided URL”, 115 | /^ <me($t)>‘, starting to benchmark the ’ \d+ ‘ given commit’ ‘s’? $/, 116 | /^ <me($t)>‘, ¦HEAD: «’ \d+\.\d+ ‘»’ $/); 117 | 118 | $t.test(‘comment after a url (without #)’, 119 | ‘bench: HEAD https://gist.githubusercontent.com/AlexDaniel/147bfa34b5a1b7d1ebc50ddc32f95f86/raw/9e90da9f0d95ae8c1c3bae24313fb10a7b766595/test.p6 ← like this!’, 120 | “{$t.our-nick}, Successfully fetched the code from the provided URL”, 121 | /^ <me($t)>‘, starting to benchmark the ’ \d+ ‘ given commit’ ‘s’? $/, 122 | /^ <me($t)>‘, ¦HEAD: «’ \d+\.\d+ ‘»’ $/); 123 | 124 | $t.test(‘wrong url’, 125 | ‘bench: HEAD http://github.com/sntoheausnteoahuseoau’, 126 | “{$t.our-nick}, It looks like a URL, but for some reason I cannot download it (HTTP status line is 404 Not Found)”); 127 | 128 | $t.test(‘wrong mime type’, 129 | ‘bench: HEAD https://www.wikipedia.org/’, 130 | “{$t.our-nick}, It looks like a URL, but mime type is ‘text/html’ while I was expecting something with ‘text/plain’ or ‘perl’ in it. I can only understand raw links, sorry.”); 131 | 132 | $t.test(‘malformed link (failed to resolve)’, 133 | ‘bench: HEAD https://perl6.or’, 134 | /^ <me($t)>‘, It looks like a URL, but for some reason I cannot download it (Failed to resolve host name 'perl6.or' with family ’\w+‘.␤Error: ’\'?‘Name or service not known’\'?‘)’ $/); 135 | 136 | $t.test(‘malformed link (could not parse)’, 137 | ‘bench: HEAD https://:P’, 138 | “{$t.our-nick}, It looks like a URL, but for some reason I cannot download it (Could not parse URI: https://:P)”); 139 | 140 | # Did you mean … ? 141 | $t.test(‘Did you mean “all”?’, 142 | ‘bench: balls say 42’, 143 | “{$t.our-nick}, ¦balls: «Cannot find this revision (did you mean “all”?)»”); 144 | $t.test(‘Did you mean “HEAD”?’, 145 | ‘bench: DEAD say 42’, 146 | “{$t.our-nick}, ¦DEAD: «Cannot find this revision (did you mean “HEAD”?)»”); 147 | $t.test(‘Did you mean some tag?’, 148 | ‘bench: 2016.55 say 42’, 149 | “{$t.our-nick}, ¦2016.55: «Cannot find this revision (did you mean “2016.05”?)»”); 150 | $t.test(‘Did you mean some commit?’, 151 | ‘bench: d2c5694e50 say 42’, 152 | “{$t.our-nick}, ¦d2c5694: «Cannot find this revision (did you mean “d2c5684”?)»”); 153 | $t.test(:15timeout, ‘Only one commit is wrong (did you mean … ?)’, 154 | ‘bench: 2015.13,2015.12^ say 42’, 155 | /^ <me($t)>‘, ¦2015.13: «Cannot find this revision (did you mean “2015.12”?)» ¦2015.12^: «’ \d+\.\d+ ‘»’ $/); 156 | $t.test(:25timeout, ‘Both commits are wrong (did you mean … ?)’, 157 | ‘bench: 2015.12^,2015.13,69fecb52eb2 say 42’, 158 | /^ <me($t)>‘, starting to benchmark the ’ \d+ ‘ given commit’ ‘s’? $/, 159 | /^ <me($t)>‘, ¦2015.12^: «’ \d+\.\d+ ‘» ¦2015.13: «Cannot find this revision (did you mean “2015.12”?)» ¦69fecb5: «Cannot find this revision (did you mean “c9ebfc2”?)»’ $/); 160 | 161 | # Other 162 | 163 | # https://github.com/Raku/whateverable/issues/38 164 | $t.test(‘Issue #38’, 165 | ‘bench: say (5..Inf).reverse.list # well, let's bench it’, 166 | “{$t.our-nick}, ¦say: «Cannot find this revision (did you mean “all”?)»”); 167 | $t.test(‘Issue #38’, 168 | ‘bench: releases say (5..Inf).reverse.list # well, let's bench it’, 169 | /^ <me($t)>‘, starting to benchmark the ’ \d+ ‘ given commit’ ‘s’? $/, 170 | “{$t.our-nick}, benchmarked the given commits, now zooming in on performance differences”, 171 | “{$t.our-nick}, https://whatever.able/fakeupload”, 172 | :240timeout); 173 | 174 | # Timeouts 175 | 176 | # TODO See issue #99 177 | 178 | 179 | $t.last-test; 180 | done-testing; 181 | END $t.end; 182 | 183 | # vim: expandtab shiftwidth=4 ft=perl6 184 | -------------------------------------------------------------------------------- /lib/Whateverable.pm6: -------------------------------------------------------------------------------- 1 | # Copyright © 2016-2023 2 | # Aleks-Daniel Jakimenko-Aleksejev <alex.jakimenko@gmail.com> 3 | # Copyright © 2016 4 | # Daniel Green <ddgreen@gmail.com> 5 | # 6 | # This program is free software: you can redistribute it and/or modify 7 | # it under the terms of the GNU Affero General Public License as published by 8 | # the Free Software Foundation, either version 3 of the License, or 9 | # (at your option) any later version. 10 | # 11 | # This program is distributed in the hope that it will be useful, 12 | # but WITHOUT ANY WARRANTY; without even the implied warranty of 13 | # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14 | # GNU Affero General Public License for more details. 15 | # 16 | # You should have received a copy of the GNU Affero General Public License 17 | # along with this program. If not, see <http://www.gnu.org/licenses/>. 18 | 19 | use File::Directory::Tree; 20 | use IRC::Client; 21 | use IRC::TextColor; 22 | use JSON::Fast; 23 | use Number::Denominate; 24 | use Pastebin::Gist; 25 | use Terminal::ANSIColor; 26 | use Text::Diff::Sift4; 27 | 28 | use Whateverable::Bits; 29 | use Whateverable::Configurable; 30 | use Whateverable::Config; 31 | use Whateverable::Discordable; 32 | use Whateverable::Heartbeat; 33 | use Whateverable::Messages; 34 | use Whateverable::Processing; 35 | 36 | unit role Whateverable does IRC::Client::Plugin; 37 | 38 | also does Helpful; 39 | also does Whateverable::Configurable; 40 | also does Whateverable::Discordable; 41 | 42 | method TWEAK { 43 | # wrap around everything to catch exceptions 44 | once { # per class 45 | self.^lookup(‘irc-to-me’).wrap: sub ($self, $msg) { 46 | return if $msg.?channel and $msg.channel ne $CONFIG<cave> 47 | and $msg.args[1].starts-with: ‘what:’; 48 | # ↑ ideally this check shouldn't be here, but it's much harder otherwise 49 | 50 | LEAVE sleep 0.02; # https://github.com/Raku/whateverable/issues/163 51 | try { 52 | my $result = callsame; 53 | return without $result; 54 | return $result but Reply($msg) if $result !~~ Promise; 55 | return start sub { 56 | my $awaited = try await $result; 57 | return handle-exception $_, $msg with $!; 58 | return without $awaited; 59 | return $awaited but Reply($msg); 60 | }() 61 | } 62 | handle-exception $!, $msg 63 | }; 64 | 65 | self.^lookup(‘filter’).wrap: sub ($self, $response) { 66 | my &filter = nextcallee; 67 | try { return filter $self, $response } 68 | return ‘Ow! Where's a camcorder when ya need one?’ if $response ~~ Enough; 69 | try { return filter $self, handle-exception $!, $response.?msg } 70 | note $!; 71 | ‘Sorry kid, that's not my department.’ 72 | }; 73 | } 74 | # TODO roles should not have TWEAK method 75 | } 76 | 77 | #↓ STDIN reset 78 | multi method irc-to-me(Message $msg where .text ~~ 79 | #↓ Matches only one space on purpose (for whitespace-only stdin) 80 | /:i^ [stdin] [‘ ’|‘=’] [clear|delete|reset|unset] $/) { 81 | $CONFIG<stdin> = $CONFIG<default-stdin>; 82 | ‘STDIN is reset to the default value’ 83 | } 84 | #↓ STDIN set 85 | multi method irc-to-me(Message $msg where .text ~~ /:i^ [stdin] [‘ ’|‘=’] $<stdin>=.* $/) { 86 | my $file = process-code ~$<stdin>, $msg; 87 | $CONFIG<stdin> = $file.slurp; 88 | unlink $file; 89 | “STDIN is set to «{shorten $CONFIG<stdin>, 200}»” # TODO is 200 a good limit 90 | } 91 | #↓ Source 92 | multi method irc-to-me(Message $ where .text ~~ /:i^ [source|url] ‘?’? \s* $/) { $CONFIG<source> } 93 | #↓ Wiki 94 | multi method irc-to-me(Message $ where .text ~~ /:i^ wiki ‘?’? \s* $/) { self.get-wiki-link } 95 | #↓ Help 96 | multi method irc-to-me(Message $msg where .text ~~ /:i^ [help|usage] ‘?’? \s* $/) { 97 | self.help($msg) ~ “ # See wiki for more examples: {self.get-wiki-link}” 98 | } 99 | #↓ Uptime 100 | multi method irc-to-me(Message $msg where .text ~~ /:i^ uptime \s* $/) { 101 | use nqp; 102 | use Telemetry; 103 | (denominate now - $*INIT-INSTANT) ~ ‘, ’ 104 | ~ T<max-rss>.fmt(‘%.2f’) ÷ 1024 ~ ‘MiB maxrss. ’ 105 | ~ (with (nqp::getcomp("Raku") || nqp::getcomp("perl6")) { 106 | “This is {.implementation} version {.config<version>} ” 107 | ~ “built on {.backend.version_string} ” 108 | ~ “implementing {.language_name} {.language_version}.” 109 | }) 110 | } 111 | #| You're welcome! 112 | sub you're-welcome is export { 113 | « 114 | ‘You're welcome!’ 115 | ‘I'm happy to help!’ 116 | ‘Anytime!’ 117 | ‘It's my pleasure!’ 118 | ‘Thank you! You love me, you really love me!’ 119 | ‘\o/’ 120 | » 121 | } 122 | #| Replying to thanks 123 | multi method irc-to-me(Message $msg where .text ~~ /:i^ [‘thank you’|‘thanks’] \s* /) { 124 | you're-welcome.pick 125 | } 126 | #| Replying to thanks 127 | multi method irc-privmsg-channel($msg where .text ~~ /:i [‘thank you’|‘thanks’] .* $($msg.server.current-nick) /) { 128 | you're-welcome.pick 129 | } 130 | #↓ Notices 131 | multi method irc-notice-me( $ --> Nil) {} # Issue #321 132 | #↓ Private messages 133 | method private-messages-allowed() { False } 134 | multi method irc-privmsg-me($ where not $.private-messages-allowed) { # TODO issue #16 135 | ‘Sorry, it is too private here. You can join #whateverable channel instead’ 136 | } 137 | #↓ Fallback 138 | multi method irc-to-me($) { 139 | ‘I cannot recognize this command. See wiki for some examples: ’ ~ self.get-wiki-link 140 | } 141 | #↓ Notify watchdog on any event 142 | multi method irc-all($) { 143 | # TODO https://github.com/zoffixznet/perl6-IRC-Client/issues/50 144 | I'm-alive; 145 | $.NEXT 146 | } 147 | 148 | method get-wiki-link { $CONFIG<wiki> ~ self.^name } 149 | 150 | #↓ Gistable output 151 | multi method filter($response where 152 | (.encode.elems > $CONFIG<message-limit> 153 | or (!~$_ and # non-empty are not gisted unless huge 154 | (?.?additional-files or $_ ~~ ProperStr)))) { 155 | # Here $response is a Str with a lot of stuff mixed in (possibly) 156 | my $description = ‘Whateverable’; 157 | my $text = colorstrip $response.?long-str // ~$response; 158 | my %files; 159 | %files<result> = $text if $text; 160 | %files.push: $_ with $response.?additional-files; 161 | 162 | if $response ~~ Reply { 163 | $description = $response.msg.server.current-nick; 164 | %files<query> = $_ with $response.?msg.?text; 165 | %files<query>:delete unless %files<query>; 166 | } 167 | my $url = upload %files, public => !%*ENV<DEBUGGABLE>, :$description; 168 | $url = $response.link-msg()($url) if $response ~~ PrettyLink; 169 | $url 170 | } 171 | 172 | #↓ Regular response (not a gist) 173 | multi method filter($text is copy) { 174 | ansi-to-irc($text) 175 | .trans([“\r\n”] => [‘␍␤’]) 176 | .trans: 177 | “\n” => ‘␤’, 178 | 3.chr => 3.chr, 0xF.chr => 0xF.chr, # keep these for IRC colors 179 | |((^32)».chr Z=> (0x2400..*).map(*.chr)), # convert all unreadable ASCII crap 180 | 127.chr => ‘␡’, /<:Cc>/ => ‘␦’ 181 | } 182 | 183 | #↓ Gists %files and returns a link 184 | sub upload(%files is copy, :$description = ‘’, Bool :$public = True) is export { 185 | if %*ENV<TESTABLE> { 186 | my $gists-path = %*ENV<TESTABLE_GISTS>; 187 | rmtree $gists-path if $gists-path.IO ~~ :d; 188 | mkdir $gists-path; 189 | spurt “$gists-path/{.key}”, .value for %files; 190 | return ‘https://whatever.able/fakeupload’; 191 | } 192 | 193 | %files = %files.pairs.map: { .key => %( ‘content’ => .value ) }; # github format 194 | 195 | my $gist = Pastebin::Gist.new(token => $CONFIG<github><access_token> || Nil); 196 | return $gist.paste: %files, desc => $description, public => $public 197 | } 198 | 199 | #↓ Sets things up and starts an IRC client 200 | method selfrun($nick is copy, @alias?) { 201 | ensure-config; 202 | 203 | use Whateverable::Builds; 204 | ensure-cloned-repos; 205 | 206 | sleep rand × $CONFIG<join-delay> if none %*ENV<DEBUGGABLE TESTABLE>; 207 | 208 | $nick ~= ‘test’ if %*ENV<DEBUGGABLE>; 209 | .run with IRC::Client.new( 210 | :$nick 211 | :userreal($nick.tc) 212 | :username($nick.substr(0, 3) ~ ‘-able’) 213 | :password(?%*ENV<TESTABLE> ?? ‘’ !! $CONFIG<irc><login password>.join: ‘:’) 214 | :@alias 215 | # IPv4 address of irc.libera.chat is hardcoded so that we can double the limit ↓ 216 | :host(%*ENV<TESTABLE> ?? ‘127.0.0.1’ !! <irc.libera.chat 130.185.232.126>.pick) 217 | :port(%*ENV<TESTABLE> ?? %*ENV<TESTABLE_PORT> !! 6667) 218 | :channels(%*ENV<DEBUGGABLE> 219 | ?? $CONFIG<cave> 220 | !! %*ENV<TESTABLE> 221 | ?? “#whateverable_$nick” 222 | !! (|$CONFIG<channels>, $CONFIG<cave>) ) 223 | :debug(?%*ENV<DEBUGGABLE>) 224 | :plugins(self) 225 | :filters( -> |c { self.filter(|c) } ) 226 | ) 227 | } 228 | 229 | # vim: expandtab shiftwidth=4 ft=perl6 230 | --------------------------------------------------------------------------------