Skip to content

Commit

Permalink
Scratch commit, no idea what's inside
Browse files Browse the repository at this point in the history
  • Loading branch information
AlexDaniel committed Mar 19, 2022
1 parent 22da601 commit 10a08cb
Show file tree
Hide file tree
Showing 8 changed files with 466 additions and 377 deletions.
4 changes: 3 additions & 1 deletion META6.json
Original file line number Diff line number Diff line change
Expand Up @@ -12,6 +12,7 @@
"Whateverable" : "lib/Whateverable.pm6",
"Whateverable::Bisection" : "lib/Whateverable/Bisection.pm6",
"Whateverable::Bits" : "lib/Whateverable/Bits.pm6",
"Whateverable::Building" : "lib/Whateverable/Building.pm6",
"Whateverable::Builds" : "lib/Whateverable/Builds.pm6",
"Whateverable::Config" : "lib/Whateverable/Config.pm6",
"Whateverable::Configurable" : "lib/Whateverable/Configurable.pm6",
Expand All @@ -23,7 +24,8 @@
"Whateverable::Processing" : "lib/Whateverable/Processing.pm6",
"Whateverable::Running" : "lib/Whateverable/Running.pm6",
"Whateverable::Uniprops" : "lib/Whateverable/Uniprops.pm6",
"Whateverable::Userlist" : "lib/Whateverable/Userlist.pm6"
"Whateverable::Userlist" : "lib/Whateverable/Userlist.pm6",
"Whateverable::Webhooks" : "lib/Whateverable/Webhooks.pm6"
},
"depends" : [
"App::GPTrixie",
Expand Down
217 changes: 217 additions & 0 deletions lib/Whateverable/Building.pm6
Original file line number Diff line number Diff line change
@@ -0,0 +1,217 @@
#!/usr/bin/env perl6
# Copyright © 2017-2020
# Aleks-Daniel Jakimenko-Aleksejev <[email protected]>
# Copyright © 2016
# Daniel Green <[email protected]>
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU Affero General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU Affero General Public License for more details.
#
# You should have received a copy of the GNU Affero General Public License
# along with this program. If not, see <http://www.gnu.org/licenses/>.

use Whateverable::Config;

unit module Whateverable::Building;

enum Project <rakudo-moar moarvm rakudo-jvm rakudo-js>;

sub latest-repo($project = $*PROJECT) { $*TMPDIR/whateverable/{$project}-repo.IO }
sub get-commits(*@args) {
run(:cwd(latest-repo $*PROJECT), :out, <git log -z --pretty=%H>, |@args)
.out.split(0.chr, :skip-empty)
}
my $TAGS-SINCE = 2014-01-01; # to build all tags
my $EVERYTHING-RANGE = 2014.01^..HEAD; # to build everything
my $ALL-SINCE = 2017-01-01; # to catch branches that are flapping in the breeze
sub get-commits-tags() { get-commits |<--tags --no-walk --since>, $TAGS-SINCE }
sub get-commits-master() { get-commits $EVERYTHING-RANGE } # slap --reverse here to build in historical order
sub get-commits-all() { get-commits |<--all --since>, $ALL-SINCE }
sub get-commits-new() { get-commits |<--all --since>, Date.today.earlier(:1month).first-date-in-month }

sub ensure-latest-git-repo() {
# ↓ Yes, separate cloned repo for every project.
my $REPO-LATEST = latest-repo;

if $REPO-LATEST.IO ~~ :d {
run :cwd($REPO-LATEST), <git pull>;
} else {
exit unless run <git clone -->, $CONFIG<projects>{$*PROJECT}<repo-origin>, $REPO-LATEST;
}
}

#| Goes through all commits and attempts to create builds
sub build-all-commits($project) is export {
my $*PROJECT = $project;
for flat(get-commits-tags, get-commits-master, get-commits-all).unique {
# Please don't waste your time trying to parallelize this.
# It's not worth it. I tried. Just wait.
process-commit $project, $_
}

# update repo so that bots know about latest commits
run :cwd($CONFIG<projects>{$project}<repo-path>), <git pull --tags>;
run :cwd($CONFIG<projects>{$project}<repo-path>), <git fetch --all>;
}

#| Repacks existing builds in order to save space
sub pack-all-builds($project) {
my %ignore;
%ignore{$_}++ for flat(get-commits-tags, get-commits-new);

my @pack;
for get-commits-all() {
next if %ignore{$_}:exists; # skip tags
next unless {$CONFIG<projects>{$project}<archives-path>}/$_.tar.zst.IO ~~ :e;
@pack.push: $_;
if @pack == 20 {
pack-it $project, @pack;
@pack = ();
}
}
}

sub get-build-revision($repo, $on-commit, $file) {
run(:cwd($repo), :out, <git show>,
{$on-commit}:tools/build/$file).out.slurp-rest.trim
}

sub process-commit($project, $commit) is export {
my $project-config = $CONFIG<projects>{$project};
my $archive-path = $project-config<archives-path>
.IO.add($commit.tar.zst).absolute;
return if $archive-path ~~ :e; # already exists

my $BUILDS-LOCATION = $*TMPDIR/whateverable/{$project}.IO;
mkdir $BUILDS-LOCATION;

use File::Temp;
my ($temp-folder,) = tempdir, :!unlink;
my $build-path = $BUILDS-LOCATION.add($commit).absolute;
my $log-path = $build-path;

# ⚡ clone
run <git clone -q -->, latest-repo($project), $temp-folder;
# ⚡ checkout to $commit
run :cwd($temp-folder), <git reset -q --hard>, $commit;

# No :merge for log files because RT#125756 RT#128594

my $config-ok;
mkdir $build-path;
{
# ⚡ configure
my $old-dir = $*CWD;
LEAVE chdir $old-dir;
chdir $temp-folder;
say »»»»» $commit: configure;
my $configure-log-fh = open :w, $log-path/configure.log;
my $configure-err-fh = open :w, $log-path/configure.err;

my @args;
given $project {
when moarvm {
@args = |<perl -- Configure.pl>, --prefix=$build-path,
--debug=3;
}
default { # assume Rakudo
@args = |<perl -- Configure.pl>, --prefix=$build-path,
|<--gen-moar --gen-nqp --backends=moar>;
my $GIT-REFERENCE = ./data.IO.absolute;
if run <grep -m1 -q -- --git-reference Configure.pl> {
@args.push: --git-reference=$GIT-REFERENCE
}
}
}

$config-ok = run :out($configure-log-fh), :err($configure-err-fh), |@args;

$configure-log-fh.close;
$configure-err-fh.close;
say »»»»» Cannot configure $commit unless $config-ok;
}

my $make-ok;
if $config-ok {
# ⚡ make
say »»»»» $commit: make;
my $make-log-fh = open :w, $log-path/make.log;
my $make-err-fh = open :w, $log-path/make.err;
my @args = do given $project {
when moarvm { |<make -j 7 -C>, $temp-folder }
when rakudo-moar { |<make -C>, $temp-folder }
}
$make-ok = run :out($make-log-fh), :err($make-err-fh), @args;
$make-log-fh.close;
$make-err-fh.close;
say »»»»» Cannot make $commit unless $make-ok;
}
if $make-ok {
# ⚡ make install
say »»»»» $commit: make install;
my $install-log-fh = open :w, $log-path/make-install.log;
my $install-err-fh = open :w, $log-path/make-install.err;
my $install-ok = run(:out($install-log-fh), :err($install-err-fh),
<make -C>, $temp-folder, install);
$install-log-fh.close;
$install-err-fh.close;
say »»»»» Cannot install $commit unless $install-ok;
}

# ⚡ compress
# No matter what we got, compress it
say »»»»» $commit: compressing;
my $proc = run(:out, :bin, <tar cf - --absolute-names --remove-files -->, $build-path);
run(:in($proc.out), :bin, <zstd -c -19 -q -o>, $archive-path);

use File::Directory::Tree;
# rmtree $temp-folder; # uncomment once safe ⚠⚠⚠⚠⚠⚠⚠⚠⚠⚠⚠⚠⚠⚠⚠⚠⚠⚠!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
}

sub pack-it($project, @pack) {
my $archives-path = $CONFIG<projects>{$project}<archives-path>;
my @paths;
for @pack {
my $archive-path = $archives-path/$_.tar.zst;
my $BUILDS-LOCATION = $*TMPDIR/whateverable/{$project}.IO;
my $build-path = $BUILDS-LOCATION/$_;
@paths.push: $build-path;

# TODO Of course it should lock on the directory like everything else does.
# The reason why we get away with this is because we run this script
# once in forever.
my $proc = run :out, :bin, <pzstd -dqc -->, $archive-path;
exit 1 unless run :in($proc.out), :bin, <tar x --absolute-names>;
}

my @bytes = @pack.join.comb(2.parse-base: 16;
my $sha-proc = run :out, :in, :bin, <sha256sum -b>;
$sha-proc.in.write: Blob.new(@bytes);
$sha-proc.in.close;
my $sha = $sha-proc.out.slurp(:close).decode.words.head; # could also be a random name, doesn't matter
exit 1 unless $sha;
my $large-archive-path = $archives-path/$sha.tar.lrz;

my $proc = run :out, :bin, <tar cf - --absolute-names --remove-files -->, |@paths;
if $large-archive-path.IO.e {
$large-archive-path.IO.unlink # remove existing (just in case)
}
if run :in($proc.out), :bin, <lrzip -q -L 9 -o>, $large-archive-path {
for @pack {
if $archives-path/$_.IO.e {
$archives-path/$_.IO.unlink # remove existing (just in case)
}
$large-archive-path.IO.symlink($archives-path/$_);
unlink $archives-path/$_.tar.zst
}
}
}

# vim: expandtab shiftwidth=4 ft=perl6
19 changes: 9 additions & 10 deletions lib/Whateverable/Builds.pm6
Original file line number Diff line number Diff line change
Expand Up @@ -28,15 +28,14 @@ unit module Whateverable::Builds;
#↓ Clones Rakudo and Moar repos and ensures some directory structure.
sub ensure-cloned-repos is export {
# TODO racing (calling this too often when nothing is cloned yet)
with $CONFIG<repo-current-rakudo-moar> {
run <git clone -->, $CONFIG<repo-origin-rakudo>, $_ if not .IO.d
}
with $CONFIG<repo-current-moarvm> {
run <git clone -->, $CONFIG<repo-origin-moarvm>, $_ if not .IO.d;
}
with $CONFIG<archives-location> {
mkdir $_/rakudo-moar;
mkdir $_/moarvm;
for $CONFIG<projects>.values {
if .<repo-path> and .<repo-origin> and not .<repo-path>.IO.e {
mkdir .<repo-path>.IO.parent;
run <git clone -->, .<repo-origin>, .<repo-path>;
# custom local origin
#run :cwd(.key), <git remote add local-origin>, …;
mkdir $_ with .<archives-location>;
}
}
True
}
Expand Down Expand Up @@ -109,7 +108,7 @@ sub fetch-build($full-commit-hash, :$backend!) is export {

my $location = $CONFIG<archives-location>.IO.add: $backend;
my $archive = $location.add: ~$0;
spurt $archive, $response.content, :bin;
spurt $archive, $response.content;

if $archive.ends-with: .lrz { # populate symlinks
my $proc = run :out, :bin, <lrzip -dqo - -->, $archive;
Expand Down
10 changes: 5 additions & 5 deletions lib/Whateverable/Config.pm6
Original file line number Diff line number Diff line change
Expand Up @@ -57,10 +57,10 @@ sub ensure-config($handle = $*IN) is export {
$CONFIG<stdin> = $CONFIG<default-stdin>;

# TODO find a way to get rid of this code
$CONFIG<repo-current-rakudo-moar> .= IO .= absolute;
$CONFIG<repo-current-moarvm> .= IO .= absolute;
$CONFIG<archives-location> .= IO .= absolute;
$CONFIG<builds-location> .= IO .= absolute;
$CONFIG<moarvm> .= IO .= absolute;
#$CONFIG<repo-current-rakudo-moar> .= IO .= absolute;
#$CONFIG<repo-current-moarvm> .= IO .= absolute;
#$CONFIG<archives-location> .= IO .= absolute;
#$CONFIG<builds-location> .= IO .= absolute;
#$CONFIG<moarvm> .= IO .= absolute;
$CONFIG<bisectable><build-lock> .= IO .= absolute;
}
60 changes: 44 additions & 16 deletions lib/Whateverable/Webhooks.pm6
Original file line number Diff line number Diff line change
Expand Up @@ -18,44 +18,72 @@
use Cro::HTTP::Router;
use Cro::HTTP::Server;

sub listen-to-webhooks(…) {
my $channel = Channel.new;
use Whateverable::Config;

unit module Whateverable::Webhooks;


class StrictTransportSecurity does Cro::Transform {
has Str:D $.secret is required;

method consumes() { Cro::TCP::Message }
method produces() { Cro::TCP::Message }

method transformer(Supply $pipeline --> Supply) {
supply {
whenever $pipeline -> $response {
$response.append-header:
'Strict-Transport-Security',
"max-age=$!max-age";
emit $response;
}
}
}
}

#| Listen to github webhooks. Returns a channel that will provide
#| payload objects.
sub listen-to-webhooks($host, $port, $secret, $channel, $irc) is export {
my $c = Channel.new;

my $application = route {
get {
with process-github-hook $_, $CONFIG<squashable><secret>, $msg.irc, $CHANNEL {
$channel.send: $_
post {
say HERE!!!!;
my $CHANNEL = %*ENV<DEBUGGABLE> ?? $CONFIG<cave> !! $channel;
with process-webhook $secret, $CHANNEL, $irc {
$c.send: $_
}
}
};

my $webhook-listener = Cro::HTTP::Server.new(
host => $CONFIG<buildable><host>,
port => $CONFIG<buildable><port>,
:$host, :$port,
:$application,
before => WebhookChecker.new($secret)
);
$webhook-listener.start;
$channel
$c
}

sub process-webhook($body, $secret, $irc, $channel) {
#| GitHub-specific processing of webhook payloads
sub process-webhook($secret, $channel, $irc) {
use Digest::SHA;
use Digest::HMAC;

my $body = $request.data;
say HERE!;
my $body = request-body -> Blob { $_ };
dd $body;
$body .= subbuf: 0..^($body - 1) if $body[*-1] == 0; # TODO trailing null byte. Why is it there?

my $hmac = sha1= ~ hmac-hex $secret, $body, &sha1;
if $hmac ne $request.headers<X-Hub-Signature> {
response.status = 400;
content Signatures didn't match;
if $hmac ne request.headers<X-Hub-Signature> {
bad-request text/plain, Signatures didn't match;
return
}

my $data = try from-json $body.decode;
without $data {
response.status = 400;
content Invalid JSON;
bad-request text/plain, Signatures didn't match;
return
}

Expand All @@ -66,7 +94,7 @@ sub process-webhook($body, $secret, $irc, $channel) {
$irc.send: :$text, where => $channel;
}

content ;
content text/plain, ;
$data
}

Expand Down
Loading

0 comments on commit 10a08cb

Please sign in to comment.