├── .github ├── CODEOWNERS ├── renovate.json └── workflows │ └── whateverable.yaml ├── .gitignore ├── .gitmodules ├── .ping ├── Akefile ├── CONTRIBUTING.md ├── Dockerfile ├── LICENSE ├── META6.json ├── README.md ├── compose.yaml ├── config-default.json ├── lib ├── Whateverable.pm6 └── Whateverable │ ├── Bisection.pm6 │ ├── Bits.pm6 │ ├── Building.pm6 │ ├── Builds.pm6 │ ├── Config.pm6 │ ├── Configurable.pm6 │ ├── Discordable.pm6 │ ├── FootgunDB.pm6 │ ├── Heartbeat.pm6 │ ├── Messages.pm6 │ ├── Output.pm6 │ ├── Processing.pm6 │ ├── Running.pm6 │ ├── Uniprops.pm6 │ ├── Userlist.pm6 │ └── Webhooks.pm6 ├── maintenance ├── fetch-irc.p6 ├── pull-uniprops ├── recompress └── verify-and-unbust ├── sandbox └── answer ├── services ├── whateverable-all.service └── whateverable@.service ├── xbin ├── Benchable.p6 ├── Bisectable.p6 ├── Bloatable.p6 ├── Buildable.p6 ├── Committable.p6 ├── Coverable.p6 ├── Evalable.p6 ├── Greppable.p6 ├── Linkable.p6 ├── Nativecallable.p6 ├── Notable.p6 ├── Quotable.p6 ├── Releasable.p6 ├── Reportable.p6 ├── Shareable.p6 ├── Sourceable.p6 ├── Squashable.p6 ├── Statisfiable.p6 ├── Tellable.p6 ├── Undersightable.p6 └── Unicodable.p6 └── xt ├── benchable.t ├── bisectable.t ├── bloatable.t ├── committable.t ├── coverable.t ├── evalable.t ├── greppable.t ├── lib └── Testable.pm6 ├── linkable.t ├── nativecallable.t ├── notable.t ├── quotable.t ├── releasable.t ├── sourceable.t ├── statisfiable.t ├── tellable.t └── unicodable.t /.github/CODEOWNERS: -------------------------------------------------------------------------------- 1 | Dockerfile @AlexDaniel 2 | compose.yaml @AlexDaniel 3 | -------------------------------------------------------------------------------- /.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 | -------------------------------------------------------------------------------- /.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 | -------------------------------------------------------------------------------- /.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 | -------------------------------------------------------------------------------- /.ping: -------------------------------------------------------------------------------- 1 | pong 2 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM rakudo-star:2023.02 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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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/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/whateverable/wiki/Installation). 24 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /lib/Whateverable.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 | 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 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 = $CONFIG; 82 | ‘STDIN is reset to the default value’ 83 | } 84 | #↓ STDIN set 85 | multi method irc-to-me(Message $msg where .text ~~ /:i^ [stdin] [‘ ’|‘=’] $=.* $/) { 86 | my $file = process-code ~$, $msg; 87 | $CONFIG = $file.slurp; 88 | unlink $file; 89 | “STDIN is set to «{shorten $CONFIG, 200}»” # TODO is 200 a good limit 90 | } 91 | #↓ Source 92 | multi method irc-to-me(Message $ where .text ~~ /:i^ [source|url] ‘?’? \s* $/) { $CONFIG } 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.fmt(‘%.2f’) ÷ 1024 ~ ‘MiB maxrss. ’ 105 | ~ (with (nqp::getcomp("Raku") || nqp::getcomp("perl6")) { 106 | “This is {.implementation} version {.config} ” 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 ~ self.^name } 149 | 150 | #↓ Gistable output 151 | multi method filter($response where 152 | (.encode.elems > $CONFIG 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 = $text if $text; 160 | %files.push: $_ with $response.?additional-files; 161 | 162 | if $response ~~ Reply { 163 | $description = $response.msg.server.current-nick; 164 | %files = $_ with $response.?msg.?text; 165 | %files:delete unless %files; 166 | } 167 | my $url = upload %files, public => !%*ENV, :$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 { 186 | my $gists-path = %*ENV; 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 || 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 if none %*ENV; 207 | 208 | $nick ~= ‘test’ if %*ENV; 209 | .run with IRC::Client.new( 210 | :$nick 211 | :userreal($nick.tc) 212 | :username($nick.substr(0, 3) ~ ‘-able’) 213 | :password(?%*ENV ?? ‘’ !! $CONFIG.join: ‘:’) 214 | :@alias 215 | # IPv4 address of irc.libera.chat is hardcoded so that we can double the limit ↓ 216 | :host(%*ENV ?? ‘127.0.0.1’ !! .pick) 217 | :port(%*ENV ?? %*ENV !! 6667) 218 | :channels(%*ENV 219 | ?? $CONFIG 220 | !! %*ENV 221 | ?? “#whateverable_$nick” 222 | !! (|$CONFIG, $CONFIG) ) 223 | :debug(?%*ENV) 224 | :plugins(self) 225 | :filters( -> |c { self.filter(|c) } ) 226 | ) 227 | } 228 | 229 | # vim: expandtab shiftwidth=4 ft=perl6 230 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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/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 | -------------------------------------------------------------------------------- /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/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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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/Processing.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 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 ($_)” if . < 0; 38 | my $output = .; 39 | $output ~= “ «exit code = $_»” if . ≠ 0; 40 | $output ~= “ «exit signal = {Signal($_)} ($_)»” if . ≠ 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, ) ~ 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; 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; 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; 159 | 160 | sub path($filename) { “$CONFIG/$filename”.IO } 161 | 162 | for %data.values { 163 | grumble ‘Invalid filename returned’ if ..contains: ‘/’|“\0”; 164 | 165 | my $score = 0; # for heuristics 166 | $score += 50 if . && . eq ‘Perl 6’; 167 | $score -= 20 if ..ends-with: ‘.pm6’; 168 | $score -= 10 if ..ends-with: ‘.t’; 169 | $score += 40 if ..contains: ‘ MAIN’; 170 | 171 | my IO $path = path .; 172 | if . ≥ 10_000_000 { 173 | $score -= 300; 174 | grumble ‘Refusing to handle files larger that 10 MB’; 175 | } 176 | if . { 177 | $score -= 100; 178 | grumble ‘Can't handle truncated files yet’; # TODO? 179 | } 180 | 181 | mkdir $path.parent; 182 | spurt $path, .; 183 | 184 | if ..ends-with: ‘.md’ | ‘.markdown’ { 185 | for ‘raku’, ‘perl6’, ‘perl’, ‘’ -> $type { 186 | if . ~~ /‘```’ $type \s* \n ~ ‘```’ (.+?) / { 187 | . = ~$0; 188 | #↓ XXX resave the file with just the code. Total hack but it works 189 | spurt $path, .; 190 | $score += 3; 191 | last 192 | } 193 | } 194 | } 195 | 196 | %scores.push: . => $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”” 202 | } 203 | path $main-file 204 | } 205 | 206 | # vim: expandtab shiftwidth=4 ft=perl6 207 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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/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 | -------------------------------------------------------------------------------- /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::SHA; 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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /sandbox/answer: -------------------------------------------------------------------------------- 1 | 42 2 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /xbin/Benchable.p6: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl6 2 | # Copyright © 2016-2023 3 | # Aleks-Daniel Jakimenko-Aleksejev 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; 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 ≠ 0 { 50 | %stats = “«run failed, exit code = $result, exit signal = $result»”; 51 | return %stats 52 | } 53 | @times.push: sprintf ‘%.4f’, $result