| 1 | #! /usr/bin/perl -w |
| 2 | ### |
| 3 | ### Import/update crypto implementations from Catacomb. |
| 4 | |
| 5 | ### This file is part of secnet. |
| 6 | ### See README for full list of copyright holders. |
| 7 | ### |
| 8 | ### secnet is free software; you can redistribute it and/or modify it |
| 9 | ### under the terms of the GNU General Public License as published by |
| 10 | ### the Free Software Foundation; either version d of the License, or |
| 11 | ### (at your option) any later version. |
| 12 | ### |
| 13 | ### secnet is distributed in the hope that it will be useful, but |
| 14 | ### WITHOUT ANY WARRANTY; without even the implied warranty of |
| 15 | ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
| 16 | ### General Public License for more details. |
| 17 | ### |
| 18 | ### You should have received a copy of the GNU General Public License |
| 19 | ### version 3 along with secnet; if not, see |
| 20 | ### https://www.gnu.org/licenses/gpl.html. |
| 21 | |
| 22 | use autodie; |
| 23 | |
| 24 | use IPC::System::Simple qw{runx capturex $EXITVAL}; |
| 25 | |
| 26 | use Data::Dumper; |
| 27 | |
| 28 | my $DONOR_VERSION = "UNKNOWN"; |
| 29 | my $DONOR_REVISION = "UNKNOWN"; |
| 30 | my $DONOR_DIR = "../catacomb"; |
| 31 | |
| 32 | (my $PROG = $0) =~ s{^.*/}{}; |
| 33 | |
| 34 | my @with_dir = ("sh", "-c", 'dir=$1; shift; cd "$dir" && exec "$@"', "."); |
| 35 | |
| 36 | sub moan ($) { print STDERR "$PROG: $_[0]\n"; } |
| 37 | |
| 38 | ###-------------------------------------------------------------------------- |
| 39 | ### Building commit messages. |
| 40 | |
| 41 | my %DONOR_PATH_MAP = (); |
| 42 | my %DONOR_REV_MAP = (); |
| 43 | my $RECIP_CACHE = (); |
| 44 | |
| 45 | sub note_path ($$) { |
| 46 | my ($donor, $recip) = @_; |
| 47 | |
| 48 | my $recip_rev = capturex "git", "rev-list", "--max-count=1", |
| 49 | "HEAD", "--", $recip; chomp $recip_rev; |
| 50 | |
| 51 | my $donor_rev; |
| 52 | if ($recip_rev eq "") |
| 53 | { $donor_rev = undef; } |
| 54 | elsif (exists $RECIP_CACHE{$recip_rev}) |
| 55 | { $donor_rev = $RECIP_CACHE{$recip_rev}; } |
| 56 | else { |
| 57 | chomp (my @msg = capturex "git", "cat-file", "commit", $recip_rev); |
| 58 | |
| 59 | my $trail = ""; |
| 60 | LINE: for (;;) { |
| 61 | last LINE unless @msg; |
| 62 | my $line = pop @msg; |
| 63 | next LINE if $trail eq "" && $line =~ /^\s*$/; |
| 64 | $trail = $line . $trail; |
| 65 | next LINE if $trail =~ /^\s/; |
| 66 | last LINE |
| 67 | unless $trail =~ /^ ([^:\s]+) \s* : \s* (| \S | \S .* \S) \s* $/x; |
| 68 | my $k = $1; my $v = $2; |
| 69 | if ($k eq "Upstream-Revision") { |
| 70 | if ($v !~ /^ [A-Fa-f0-9]+ $/x) { |
| 71 | moan "ignoring bad `Upstream-Revision' `$v' in commit $recip_rev"; |
| 72 | next LINE; |
| 73 | } |
| 74 | $donor_rev = $v; |
| 75 | last LINE; |
| 76 | } |
| 77 | } |
| 78 | defined $donor_rev or |
| 79 | moan "failed to find upstream version in commit $recip_rev"; |
| 80 | $RECIP_CACHE{$recip_rev} = $donor_rev; |
| 81 | } |
| 82 | $DONOR_PATH_MAP{$donor} = $recip; |
| 83 | $DONOR_REV_MAP{$donor} = $donor_rev; |
| 84 | } |
| 85 | |
| 86 | sub commit_changes () { |
| 87 | my $msg = ""; |
| 88 | my $any_changes = 0; |
| 89 | |
| 90 | ## Stage updated files for commit. |
| 91 | my %recip_map; |
| 92 | for my $path (keys %DONOR_PATH_MAP) |
| 93 | { push @{$recip_map{$DONOR_PATH_MAP{$path}}}, $path; } |
| 94 | runx "git", "update-index", "--add", "--", keys %recip_map; |
| 95 | |
| 96 | ## Inspect the changed files. Notice whether we've actually changed or |
| 97 | ## added files. |
| 98 | chomp (my @diff = capturex "git", "diff-index", "--cached", "HEAD"); |
| 99 | my %changed = (); |
| 100 | my %new = (); |
| 101 | for my $line (@diff) { |
| 102 | $line =~ /^ : |
| 103 | [0-7]+ \ [0-7]+ \ # |
| 104 | ([A-Fa-f0-9]+) \ ([A-Fa-f0-9]+) \ # |
| 105 | ([ACDMRTUX])\d* \t |
| 106 | ([^\t]+) (?: \t ([^\t]+))? $/x |
| 107 | or die "incomprehensible git-diff line `$line'"; |
| 108 | my $path = ($3 eq "C" or $3 eq "R") ? $5 : $4; |
| 109 | $changed{$path} = 1; $new{$path} = ($1 !~ /[^0]/); |
| 110 | } |
| 111 | |
| 112 | ## Files which haven't changed aren't interesting any more. |
| 113 | for my $path (keys %DONOR_PATH_MAP) { |
| 114 | my $recip = $DONOR_PATH_MAP{$path}; |
| 115 | if (!$changed{$recip}) { |
| 116 | delete $recip_map{$recip}; |
| 117 | delete $DONOR_REV_MAP{$path}; |
| 118 | } |
| 119 | } |
| 120 | if (!%recip_map) { moan "no changes to import"; return ""; } |
| 121 | |
| 122 | ## Build the commit preamble. |
| 123 | $msg .= "Update crypto code from Catacomb $DONOR_VERSION.\n\n"; |
| 124 | $msg .= "This change committed automatically by `$PROG'.\n\n"; |
| 125 | |
| 126 | ## Construct the summary of changes. |
| 127 | my @recip = sort keys %recip_map; |
| 128 | for my $recip (@recip) { |
| 129 | my $disp = $new{$recip} ? "new" : "updated"; |
| 130 | my $line = " * Import $disp `$recip' from upstream"; |
| 131 | my @p = sort @{$recip_map{$recip}}; |
| 132 | for (my $i = 0; $i < @p; $i++) { |
| 133 | my $p = $p[$i]; |
| 134 | if (!$i) { } |
| 135 | else { |
| 136 | @p == 2 or $line .= ","; |
| 137 | if ($i == @p - 1) { |
| 138 | if (length($line) + 4 > 72) |
| 139 | { $msg .= $line . "\n"; $line = " "; } |
| 140 | $line .= " and"; |
| 141 | } |
| 142 | } |
| 143 | if (length($line) + length($p) + 3 > 72) |
| 144 | { $msg .= $line . "\n"; $line = " "; } |
| 145 | $line .= " `$p'" |
| 146 | } |
| 147 | $msg .= $line . ".\n"; |
| 148 | } |
| 149 | |
| 150 | ## Now the detailed list of upstream commits. |
| 151 | $msg .= "\nDetailed list of changes:\n"; |
| 152 | my @paths; my @roots; |
| 153 | for my $path (keys %DONOR_REV_MAP) { |
| 154 | my $rev = $DONOR_REV_MAP{$path}; |
| 155 | if (defined $rev) { push @paths, $path; push @roots, $rev; } |
| 156 | } |
| 157 | chomp (my @revs = capturex @with_dir, $DONOR_DIR, |
| 158 | "git", "rev-list", "--reverse", |
| 159 | "HEAD", "--not", @roots, "--", @paths); |
| 160 | |
| 161 | for my $rev (@revs) { |
| 162 | my @affected = (); |
| 163 | for my $path (@paths) { |
| 164 | runx [0, 1], @with_dir, $DONOR_DIR, |
| 165 | "git", "merge-base", "--is-ancestor", |
| 166 | $DONOR_REV_MAP{$path}, $rev; |
| 167 | push @affected, $path if !$EXITVAL; |
| 168 | } |
| 169 | $msg .= "\n" . join "", |
| 170 | grep { s/\s+$/\n/ } |
| 171 | map { " " . $_ } |
| 172 | capturex @with_dir, $DONOR_DIR, |
| 173 | "git", "show", "--stat", $rev, "--", @affected; |
| 174 | } |
| 175 | |
| 176 | ## The trailer, so that we can see where we left off. |
| 177 | $msg .= "\nUpstream-Revision: $DONOR_REVISION\n"; |
| 178 | |
| 179 | ## Commit everything. |
| 180 | runx "git", "commit", "--edit", "--message", $msg, @recip; |
| 181 | } |
| 182 | |
| 183 | ###-------------------------------------------------------------------------- |
| 184 | ### Converting C sources and headers. |
| 185 | |
| 186 | sub convert_c ($$) { |
| 187 | my ($from, $to) = @_; |
| 188 | ## Convert a C source or header file. FROM is the source file name; TO is |
| 189 | ## the destination file name. Also clobbers `TO.new'. |
| 190 | |
| 191 | (my $file = $from) =~ s{^ .* / ([^/]+ / [^/]+) $}{$1}x; |
| 192 | |
| 193 | open my $in, "<", $from; |
| 194 | open my $out, ">", "$to.new"; |
| 195 | |
| 196 | ## Control state. |
| 197 | my $pending_blank = 0; # waiting to output a blank line? |
| 198 | my $skip_reason = ""; # why should we skip output? |
| 199 | my $trim_spaces = -1; # number of leading spaces to trim - 1 |
| 200 | |
| 201 | my $if_open = 0; # current `#if' emitted to output? |
| 202 | my $if_skippable = 0; # current `#if' not propagated? |
| 203 | my $if_skipping = 0; # current `#if' body being skipped? |
| 204 | my $if_unindent = 0; # indent level removed by this `#if' |
| 205 | my @if_stack = (); # stack of previous `$if_...' vars |
| 206 | my $if_level = 0; # current `#if' nesting level |
| 207 | |
| 208 | my @lookahead = (); # stack of lines to be read again |
| 209 | |
| 210 | LINE: for (;;) { |
| 211 | my $line; |
| 212 | if (@lookahead) { $line = pop @lookahead; } |
| 213 | else { $line = <$in>; defined $line or last LINE; chomp $line; } |
| 214 | |
| 215 | ## Track blank lines so that we don't leave huge gaps. Also, if this is |
| 216 | ## a blank line and we were skipping a paragraph, then we've reached the |
| 217 | ## end. |
| 218 | if ($line =~ /^\s*$/) { |
| 219 | if ($skip_reason eq "para") { $skip_reason = ""; } |
| 220 | $pending_blank = 1; next LINE; |
| 221 | } |
| 222 | |
| 223 | ## If we're skipping a defun, and this is the end of it, then stop |
| 224 | ## skipping. (But swallow the line.) |
| 225 | if ($skip_reason eq "defun" && $line =~ /^\}/) |
| 226 | { $skip_reason = ""; next LINE; } |
| 227 | |
| 228 | ## If this is a stanza heading, inspect the stanza. |
| 229 | if ($line =~ m{^/\* --- (.*) --- \*/?$}) { |
| 230 | my $stanza = $1; |
| 231 | |
| 232 | ## If we're skipping a stanza, then stop skipping. |
| 233 | if ($skip_reason eq "stanza") { $skip_reason = ""; } |
| 234 | |
| 235 | ## On the other hand, there are stanze we don't want. |
| 236 | if ($stanza eq '@sha3_{224,256,384,512}_set@' || |
| 237 | $stanza eq '@sha3_state@' || |
| 238 | $stanza eq '@shake_mask@' || |
| 239 | $stanza eq '@shake{128,256}_rand@' || |
| 240 | $stanza eq '@cshake{128,256}_rand@' || |
| 241 | $stanza eq "Generic hash interface" || |
| 242 | $stanza eq "Hash interface" || |
| 243 | $stanza eq "Generic cipher interface" || |
| 244 | $stanza eq "Cipher interface" || |
| 245 | $stanza eq "Random generator interface") |
| 246 | { $skip_reason = "stanza"; } |
| 247 | } |
| 248 | |
| 249 | ## If this is a section heading, inspect the heading. |
| 250 | if ($line =~ m{^/\*-{5} (.*) -{5,}\*/?$}) { |
| 251 | my $sect = $1; |
| 252 | |
| 253 | ## If we're skipping a section or a stanza, then stop skipping. |
| 254 | if ($skip_reason eq "section" || $skip_reason eq "stanza") |
| 255 | { |
| 256 | $skip_reason = ""; } |
| 257 | |
| 258 | ## On the other hand, there are sections we don't want. |
| 259 | if ($sect eq "Signed integer types") { |
| 260 | $skip_reason = "section"; |
| 261 | print $out <<EOF; |
| 262 | /*----- Signed integer types ----------------------------------------------*/ |
| 263 | |
| 264 | typedef int32_t int32; |
| 265 | typedef int64_t int64; |
| 266 | #define HAVE_INT64 1 |
| 267 | EOF |
| 268 | $pending_blank = 1; |
| 269 | } elsif ($sect eq "Test rig" || |
| 270 | $sect eq "Key fetching" || |
| 271 | $sect eq "The KMAC variable-length PRF") |
| 272 | { $skip_reason = "section"; } |
| 273 | } |
| 274 | |
| 275 | ## Handle `#if' and friends. This is not especially principled. |
| 276 | if ($line =~ /^ (\s* \# \s*) |
| 277 | (if|elif|ifdef|ifndef) |
| 278 | (\s+) |
| 279 | (\S|\S.*\S) |
| 280 | (\s*) |
| 281 | $/x) { |
| 282 | my $hash = $1; my $kw = $2; my $s1 = $3; my $cond = $4; |
| 283 | |
| 284 | ## Categorize the conditional directive. |
| 285 | my $test; my $sense; |
| 286 | if ($kw eq "if" || $kw eq "elif") { $test = "if"; $sense = 1; } |
| 287 | elsif ($kw eq "ifdef") { $test = "ifdef"; $sense = 1; } |
| 288 | elsif ($kw eq "ifndef") { $test = "ifdef"; $sense = 0; } |
| 289 | else { die "confused!"; } |
| 290 | |
| 291 | ## Now analyse the condition and decide what we should do about it. |
| 292 | my $skip = undef; my $unindent = 0; |
| 293 | |
| 294 | if ($test eq "ifdef" && $cond eq "HAVE_UINT64") |
| 295 | { $skip = 0; $unindent = 2; } |
| 296 | |
| 297 | elsif ($test eq "if" && |
| 298 | $cond eq "!defined(F25519_IMPL) && defined(HAVE_INT64)") |
| 299 | { $skip = 1; } |
| 300 | elsif ($test eq "ifdef" && $cond eq "F25519_IMPL") { $skip = 0; } |
| 301 | elsif ($test eq "if" && $cond eq "F25519_IMPL == 26") { $skip = 0; } |
| 302 | elsif ($test eq "if" && $cond eq "F25519_IMPL == 10") { $skip = 1; } |
| 303 | |
| 304 | elsif ($test eq "if" && |
| 305 | $cond eq "!defined(FGOLDI_IMPL) && defined(HAVE_INT64)") |
| 306 | { $skip = 1; } |
| 307 | elsif ($test eq "if" && $cond eq "FGOLDI_IMPL == 28") { $skip = 0; } |
| 308 | elsif ($test eq "if" && $cond eq "FGOLDI_IMPL == 12") { $skip = 1; } |
| 309 | elsif ($test eq "ifdef" && $cond eq "FGOLDI_IMPL") { $skip = 0; } |
| 310 | |
| 311 | elsif ($test eq "ifdef" && $cond eq "SCAF_IMPL") { $skip = 0; } |
| 312 | elsif ($test eq "if" && $cond eq "SCAF_IMPL == 32") { $skip = 0; } |
| 313 | elsif ($test eq "if" && $cond eq "SCAF_IMPL == 16") { $skip = 1; } |
| 314 | |
| 315 | elsif ($test eq "if" && $cond =~ /^(.*) \|\| defined\(TEST_RIG\)/) |
| 316 | { $cond = $1; } |
| 317 | |
| 318 | elsif ($test eq "ifdef" && ($cond eq "CATACOMB_GCIPHER_H" || |
| 319 | $cond eq "CATACOMB_GHASH_H" || |
| 320 | $cond eq "CATACOMB_GMAC_H" || |
| 321 | $cond eq "CATACOMB_GRAND_H" || |
| 322 | $cond eq "CATACOMB_KEY_H")) |
| 323 | { $skip = 0; } |
| 324 | |
| 325 | elsif ($test eq "ifdef" && $cond eq "NEG_TWOC") |
| 326 | { $skip = 0; $unindent = 2 if $file eq "math/qfarith.h"; } |
| 327 | |
| 328 | ## Adjust the processor state to do something sensible. |
| 329 | if (!$sense && defined $skip) { $skip = !$skip; } |
| 330 | |
| 331 | if ($kw eq "elif") { |
| 332 | $trim_spaces -= $if_unindent; |
| 333 | if ($if_skipping) { $skip_reason = ""; } |
| 334 | if (!$if_open && !defined $skip) { $kw = "if"; $if_open = 1; } |
| 335 | elsif ($if_open && defined $skip) |
| 336 | { $if_open = 0; print "${hash}endif\n" unless $skip_reason; } |
| 337 | } else { |
| 338 | $if_level++; |
| 339 | push @if_stack, |
| 340 | [$if_open, $if_skippable, $if_skipping, $if_unindent]; |
| 341 | $if_open = !defined $skip; |
| 342 | } |
| 343 | $if_skippable = defined $skip; $if_skipping = $skip && !$skip_reason; |
| 344 | if ($if_skipping && !$skip_reason) |
| 345 | { $skip_reason = "if.$if_level"; } |
| 346 | $if_unindent = $unindent; $trim_spaces += $unindent; |
| 347 | |
| 348 | ## Maybe produce some output. |
| 349 | if (defined $skip) { next LINE; } |
| 350 | else { $line = $hash . $kw . $s1 . $cond; } |
| 351 | } elsif ($line =~ /^ \s* \# \s* else \s* $/x) { |
| 352 | if ($if_skippable) { |
| 353 | if ($if_skipping) { |
| 354 | $if_skipping = 0; |
| 355 | $skip_reason = "" if $skip_reason eq "if.$if_level"; |
| 356 | } else { |
| 357 | $if_skipping = 1; |
| 358 | $skip_reason = "if.$if_level" if !$skip_reason; |
| 359 | } |
| 360 | next LINE; |
| 361 | } |
| 362 | } elsif ($line =~ /^ \s* \# \s* endif \s* $/x) { |
| 363 | my $was_open = $if_open; |
| 364 | if ($if_skipping) |
| 365 | { $skip_reason = "" if $skip_reason eq "if.$if_level"; } |
| 366 | $trim_spaces -= $if_unindent; |
| 367 | ($if_open, $if_skippable, $if_skipping, $if_unindent) = |
| 368 | @{ pop @if_stack }; |
| 369 | $if_level--; |
| 370 | if (!$was_open) { next LINE; } |
| 371 | } |
| 372 | |
| 373 | ## If we're skipping something, then do that. |
| 374 | if ($skip_reason) { next LINE; } |
| 375 | |
| 376 | ## Inspect header inclusions. |
| 377 | if ($line =~ /^ (\s* \# \s* include \s+) (["<] [^">]* [">]) \s* $/x) { |
| 378 | my $incl = $1; my $hdr = $2; |
| 379 | if ($hdr eq '<mLib/bits.h>') { $hdr = '"fake-mLib-bits.h"'; } |
| 380 | elsif ($hdr eq '"hash.h"' || $hdr eq '"ghash-def.h"') { next LINE; } |
| 381 | elsif ($hdr eq '"ct.h"') { next LINE; } |
| 382 | $line = $incl . $hdr; |
| 383 | } |
| 384 | |
| 385 | ## We don't have Catacomb's `config.h'. |
| 386 | if ($line =~ /^ \# \s* include \s+ "config\.h" \s* $/x) |
| 387 | { next LINE; } |
| 388 | |
| 389 | ## Zap the 16-bit implementations. |
| 390 | if ($line =~ /^ int16 (p10\[26\]|p12\[40\])\;$/) |
| 391 | { next LINE; } |
| 392 | |
| 393 | ## Maybe trim leading indentation. |
| 394 | if ($trim_spaces > 0) { |
| 395 | $line =~ s/^ (\#?) \ ? \ {$trim_spaces}/$1/x |
| 396 | or $trim_spaces = -1; |
| 397 | } |
| 398 | |
| 399 | ## Other random lines we don't want. |
| 400 | if ($line eq "extern const octet shake128_keysz[], shake256_keysz[];") |
| 401 | { next LINE; } |
| 402 | |
| 403 | if ($line eq "const octet") { |
| 404 | die "fixme: read from lookahead" if @lookahead; |
| 405 | my $line1 = <$in>; chomp $line1; |
| 406 | my $line2 = <$in>; chomp $line2; |
| 407 | if ($line1 =~ /^ shake128_keysz\[] = .*,/ && |
| 408 | $line2 =~ /^ shake256_keysz\[] = .*;/) |
| 409 | { next LINE; } |
| 410 | else |
| 411 | { push @lookahead, $line2, $line1; } |
| 412 | } |
| 413 | |
| 414 | if ($line eq "static void rightenc_sz(shake_ctx *ctx, size_t n)") |
| 415 | { $skip_reason = "defun"; next LINE; } |
| 416 | |
| 417 | ## Other random tweaks. |
| 418 | $line =~ s/ct_memeq/consttime_memeq/g; |
| 419 | $line =~ s/\bSHA512_HASHSZ\b/SHA512_DIGEST_SIZE/g; |
| 420 | $line =~ s/\bsha512_ctx\b/struct sha512_ctx/g; |
| 421 | $line =~ s/\bsha512_init\b/sha512_init_ctx/g; |
| 422 | $line =~ s{\b sha512_hash \( ([^,]+) (,\s*) ([^,]+) (,\s*) ([^)]+) \)} |
| 423 | {sha512_process_bytes($3$2$5$2$1)}gx; |
| 424 | $line =~ s/\bsha512_done\b/sha512_finish_ctx/g; |
| 425 | $line =~ s/\bdo\s*;\s*while\b/do {} while/g; |
| 426 | |
| 427 | ## Fix the provenance note. |
| 428 | if ($line =~ /^ \* This file is part of Catacomb/) { |
| 429 | print $out <<EOF; |
| 430 | * This file is part of secnet. |
| 431 | * See README for full list of copyright holders. |
| 432 | * |
| 433 | * secnet is free software; you can redistribute it and/or modify it |
| 434 | * under the terms of the GNU General Public License as published by |
| 435 | * the Free Software Foundation; either version d of the License, or |
| 436 | * (at your option) any later version. |
| 437 | * |
| 438 | * secnet is distributed in the hope that it will be useful, but |
| 439 | * WITHOUT ANY WARRANTY; without even the implied warranty of |
| 440 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
| 441 | * General Public License for more details. |
| 442 | * |
| 443 | * You should have received a copy of the GNU General Public License |
| 444 | * version 3 along with secnet; if not, see |
| 445 | * https://www.gnu.org/licenses/gpl.html. |
| 446 | * |
| 447 | * This file was originally part of Catacomb, but has been automatically |
| 448 | * modified for incorporation into secnet: see `import-catacomb-crypto' |
| 449 | * for details. |
| 450 | EOF |
| 451 | next LINE; |
| 452 | } |
| 453 | |
| 454 | ## Print the line. |
| 455 | if ($pending_blank && $line !~ /^\s*\}\s*/) { print $out "\n"; } |
| 456 | print $out "$line\n"; $pending_blank = 0; |
| 457 | } |
| 458 | |
| 459 | ## Done. |
| 460 | close $in; |
| 461 | close $out; rename "$to.new", "$to"; |
| 462 | } |
| 463 | |
| 464 | ###-------------------------------------------------------------------------- |
| 465 | ### Converting a test-vector file. |
| 466 | |
| 467 | sub convert_test ($$$) { |
| 468 | my ($from, $to, $varmap) = @_; |
| 469 | ## Convert a test vector file . FROM is a listref of source |
| 470 | ## specifications; TO is the destination file name. `TO.new' is also |
| 471 | ## clobbered. The VARMAP is a listref containing test specifications. |
| 472 | ## |
| 473 | ## A source specification is a string of one of the following forms. |
| 474 | ## |
| 475 | ## * `=HEAD-COMMENT' -- set the first-line comment. (Otherwise it's |
| 476 | ## taken from the first comment line of the first input file.) |
| 477 | ## |
| 478 | ## * `[FORMAT:]PATH -- read test data from the PATH, and parse it |
| 479 | ## according to FORMAT. |
| 480 | ## |
| 481 | ## FORMATs supported are `std' (Catacomb's native format), `ed25519djb' |
| 482 | ## (Bernstein's Ed25519 test vector file, and `sha3' (NIST's CAVP format |
| 483 | ## for SHA3 test vectors). |
| 484 | ## |
| 485 | ## A test specification is a /pair/ of items (the list as a whole is |
| 486 | ## suitable for conversion into a Perl hash): each key names a kind of |
| 487 | ## test; and each value is either a listref of register names or a coderef |
| 488 | ## for a formatting function, called as FMT(OUTREF, FIELDS), where OUTREF |
| 489 | ## is a scalar-ref of the output to build, and FIELDS is the list of |
| 490 | ## test-vector fields. |
| 491 | ## |
| 492 | ## Yes, this is quite hairy. |
| 493 | |
| 494 | ## Convert the VARMAP into an actual hash. (We want the list version |
| 495 | ## because it has the correct output order.) |
| 496 | my %varmap = @$varmap; |
| 497 | |
| 498 | ## Global control state. |
| 499 | my $filehead = ""; # first-line comment |
| 500 | my %testout = (); # map tests to output buffers |
| 501 | |
| 502 | ## Work through each input spec. |
| 503 | INPUT: for my $input (@$from) { |
| 504 | |
| 505 | ## Handle a headline comment. |
| 506 | if ($input =~ /^=(.*)$/) { |
| 507 | $filehead and die "two heads are not better than one"; |
| 508 | $filehead = $1; next INPUT; |
| 509 | } |
| 510 | |
| 511 | ## Split the format specifier from the pathname. |
| 512 | my $fmt = "std"; |
| 513 | if ($input =~ /^([^:]*):(.*)$/) { $fmt = $1; $input = $2; } |
| 514 | |
| 515 | ## Get the input basename. |
| 516 | (my $base = $input) =~ s{^.*/}{}; |
| 517 | |
| 518 | ## Open the input file. |
| 519 | open my $in, "<", $input; |
| 520 | |
| 521 | ## Per-input control state. |
| 522 | my $head = ""; # per-file comment to insert |
| 523 | my $test = undef; # current test category |
| 524 | my $vars = undef; # output specifier for current test |
| 525 | my $sha3_kind; # SHA3 test kind: `kat' or `mct' |
| 526 | my $sha3_len = 8; my $sha3_msg; # SHA3 test state |
| 527 | my $sha3_prev; # ... |
| 528 | my @lookahead = (); # stack of lines to be read again |
| 529 | |
| 530 | ## Per-format setup. |
| 531 | if ($fmt eq "ed25519djb") { |
| 532 | ## Just record that this from djb's reference. |
| 533 | |
| 534 | for my $t (qw{pubkey sign verify}) { |
| 535 | $testout{$t} .= |
| 536 | "## Test vectors from Dan Bernstein's reference implementation.\n\n"; |
| 537 | } |
| 538 | } elsif ($fmt eq "sha3") { |
| 539 | ## Set up to parse the NIST CAVP test files. |
| 540 | |
| 541 | my $tail; |
| 542 | my $alg; my $sep; my $bits; my $hex; |
| 543 | |
| 544 | ## Pick apart the file name. |
| 545 | if ($base =~ /^SHA3_(.*)$/) |
| 546 | { $tail = $1; $alg = "sha3"; $sep = "-"; $hex = "-hex"; } |
| 547 | elsif ($base =~ /^SHAKE(.*)$/) |
| 548 | { $tail = $1; $alg = "shake"; $sep = ""; $hex = ""; } |
| 549 | else |
| 550 | { die "strange `$base'"; } |
| 551 | |
| 552 | if ($tail =~ /^(.*)LongMsg\.rsp/) |
| 553 | { $sha3_kind = "kat"; $bits = $1; } |
| 554 | elsif ($tail =~ /^(.*)ShortMsg\.rsp/) |
| 555 | { $sha3_kind = "kat"; $bits = $1; } |
| 556 | elsif ($tail =~ /^(.*)VariableOut\.rsp/) |
| 557 | { $sha3_kind = "kat"; $bits = $1; } |
| 558 | elsif ($tail =~ /^(.*)Monte\.rsp/) |
| 559 | { $sha3_kind = "mct"; $bits = $1; } |
| 560 | |
| 561 | ## Determine the test name. |
| 562 | if ($sha3_kind eq "kat") { $test = $alg . $sep . $bits . $hex; } |
| 563 | elsif ($sha3_kind eq "mct") { $test = $alg . $sep . $bits . "-mct"; } |
| 564 | |
| 565 | ## Set the per-test banner. |
| 566 | $testout{$test} .= "## Converted from NIST test vectors\n"; |
| 567 | } |
| 568 | |
| 569 | ## Work through the input file. |
| 570 | LINE: for (;;) { |
| 571 | my $line; |
| 572 | if (@lookahead) { $line = pop @lookahead; } |
| 573 | else { $line = <$in>; defined $line or last LINE; chomp $line; } |
| 574 | |
| 575 | ## Ignore empty lines. |
| 576 | if ($line =~ /^\s*$/) { next LINE; } |
| 577 | |
| 578 | ## Copy comments to the output. An initial comment becomes the |
| 579 | ## headline. Top-level comments get written to /every/ test chunk |
| 580 | ## extracted from this input file. Comments within test chunks get |
| 581 | ## added to the output chunk. |
| 582 | if ($line =~ /^ \s* (?:\#+) \s* (| [^#\s] (?: .* \S)?) \s* $/x) { |
| 583 | if (!$filehead) { $filehead = $1; next LINE; } |
| 584 | my $buf = "## $1\n" if $1; |
| 585 | COMMENT: for (;;) { |
| 586 | die "fixme: read from lookahead" if @lookahead; |
| 587 | $line = <$in>; defined $line or last COMMENT; chomp $line; |
| 588 | last COMMENT |
| 589 | unless $line =~ /^ \s* (?:\#+) \s* (| [^#\s] (?: .* \S)?) $/x; |
| 590 | $buf .= "## $1\n"; |
| 591 | } |
| 592 | push @lookahead, $line if defined $line; |
| 593 | if (defined $test) { $testout{$test} .= $buf; } |
| 594 | else { $head = $buf . "\n"; } |
| 595 | next LINE; |
| 596 | } |
| 597 | |
| 598 | ## Handle strange formats. |
| 599 | if ($fmt eq "ed25519djb") { |
| 600 | ## Bernstein's format is strangely redundant. Pick out the |
| 601 | ## interesting parts. |
| 602 | |
| 603 | $line =~ s/^ ([^:]{64}) ([^:]{64}) : |
| 604 | \2 : |
| 605 | ([^:]*) : |
| 606 | ([^:]{128}) \3 : |
| 607 | $/$1:$2:$3:$4/x |
| 608 | or die "bogus djb line"; |
| 609 | my ($k, $K, $m, $s) = ($1, $2, $3, $4); |
| 610 | |
| 611 | ## Test public-key generation. |
| 612 | $testout{"pubkey"} .= <<EOF . "\n"; |
| 613 | a $k |
| 614 | A $K |
| 615 | EOF |
| 616 | |
| 617 | ## Test signing. |
| 618 | $testout{"sign"} .= <<EOF . "\n"; |
| 619 | a $k |
| 620 | m $m |
| 621 | sig $s |
| 622 | EOF |
| 623 | |
| 624 | ## Test successful verification. |
| 625 | $testout{"verify"} .= <<EOF . "\n"; |
| 626 | A $K |
| 627 | m $m |
| 628 | sig $s |
| 629 | rc 0 |
| 630 | EOF |
| 631 | |
| 632 | ## Test failed verification with negated key. |
| 633 | (my $Kneg = $K) =~ s{([0-9a-f]{2})$} |
| 634 | { sprintf "%02x", hex($1) ^ 0x80 }e; |
| 635 | $testout{"verify"} .= <<EOF . "\n"; |
| 636 | A $Kneg |
| 637 | m $m |
| 638 | sig $s |
| 639 | rc -1 |
| 640 | EOF |
| 641 | |
| 642 | ## Test failed verification with clobbered key. |
| 643 | (my $Kzap = $K) =~ s{^([0-9a-f]{2})} |
| 644 | { sprintf "%02x", hex($1) ^ 0xff }e; |
| 645 | $testout{"verify"} .= <<EOF . "\n"; |
| 646 | A $Kzap |
| 647 | m $m |
| 648 | sig $s |
| 649 | rc -1 |
| 650 | EOF |
| 651 | |
| 652 | ## Test failed verification with clobbered message. |
| 653 | (my $mzap = $m) =~ s{^([0-9a-f]{2})} |
| 654 | { sprintf "%02x", hex($1) ^ 0xff }e; |
| 655 | $mzap = "00" unless $m; |
| 656 | $testout{"verify"} .= <<EOF . "\n"; |
| 657 | A $K |
| 658 | m $mzap |
| 659 | sig $s |
| 660 | rc -1 |
| 661 | EOF |
| 662 | |
| 663 | ## Test failed verification with clobbered signature. |
| 664 | (my $szap = $s) =~ s{^([0-9a-f]{2})} |
| 665 | { sprintf "%02x", hex($1) ^ 0xff }e; |
| 666 | $testout{"verify"} .= <<EOF . "\n"; |
| 667 | A $K |
| 668 | m $m |
| 669 | sig $szap |
| 670 | rc -1 |
| 671 | EOF |
| 672 | next LINE; |
| 673 | } elsif ($fmt eq "sha3") { |
| 674 | ## Parse the wretched NIST file. Alas, there's all sorts of cruft |
| 675 | ## that isn't actually very interesting, so the parsing is rather |
| 676 | ## slack. |
| 677 | |
| 678 | if ($sha3_kind eq "kat") { |
| 679 | ## Known-answer tests. |
| 680 | |
| 681 | if ($line =~ /^ Len \s* = \s* ([0-9]+) \s* $/x) |
| 682 | { $sha3_len = $1; } |
| 683 | elsif ($line =~ /^ Msg \s* = \s* ([A-Fa-f0-9]+) \s* $/x) |
| 684 | { $sha3_msg = $sha3_len == 0 ? "" : lc $1; } |
| 685 | elsif ($line =~ /^ (?: MD | Output) \s* = \s* |
| 686 | ([A-Fa-f0-9]+) \s* $/x) { |
| 687 | my $hash = lc $1; |
| 688 | $sha3_len%8 == 0 and $testout{$test} .= <<EOF; |
| 689 | m $sha3_msg |
| 690 | h $hash |
| 691 | |
| 692 | EOF |
| 693 | } |
| 694 | } elsif ($sha3_kind eq "mct") { |
| 695 | ## Monte-Carlo tests. |
| 696 | |
| 697 | if ($line =~ /^ MD \s* = \s* ([A-Fa-f0-9]+) \s* $/x) { |
| 698 | my $hash = lc $1; |
| 699 | defined $sha3_prev and $testout{$test} .= <<EOF; |
| 700 | n 1000 |
| 701 | m $sha3_prev |
| 702 | h $hash |
| 703 | |
| 704 | EOF |
| 705 | $sha3_prev = $hash; |
| 706 | } |
| 707 | } |
| 708 | next LINE; |
| 709 | } elsif ($fmt ne "std") { die "fmt `$fmt'?"; } |
| 710 | |
| 711 | ## Deal with the top-level structure. |
| 712 | if (!defined $test) { |
| 713 | if ($line =~ /^ \s* ([A-Za-z0-9-]+) \s* \{ \s* $/x) { |
| 714 | $test = $1; |
| 715 | die "unknown test `$test'" unless exists $varmap{$test}; |
| 716 | $vars = $varmap{$test}; |
| 717 | $testout{$test} .= $head; |
| 718 | } else { |
| 719 | die "junk found; expected test head in `$input'" |
| 720 | } |
| 721 | next LINE; |
| 722 | } |
| 723 | |
| 724 | ## Check for the end of a test chunk. |
| 725 | if ($line =~ /^ \s* \} \s* $/x) { |
| 726 | $test = undef; $vars = undef; |
| 727 | next LINE; |
| 728 | } |
| 729 | |
| 730 | ## So, read a test vector. (This is not correct, but good enough.) |
| 731 | my $vector = "$line"; |
| 732 | VECTOR: for (;;) { |
| 733 | last VECTOR if $vector =~ s/\;$//; |
| 734 | die "fixme: read from lookahead" if @lookahead; |
| 735 | $line = <$in>; defined $line or die "eof in test chunk"; chomp $line; |
| 736 | $vector .= " $line"; |
| 737 | } |
| 738 | |
| 739 | ## Split it into fields. We have to handle quoting, but not very well. |
| 740 | my @f = (); |
| 741 | FIELD: while ($vector) { |
| 742 | if ($vector =~ /^ \s* $/) { last FIELD; } |
| 743 | if ($vector =~ /^ \s* " ([^"]*) " (\s+ .*|) $/x) |
| 744 | { push @f, $1; $vector = $2; } |
| 745 | elsif ($vector =~ /^ \s* (\S+) (\s+ .*|) $/x) |
| 746 | { push @f, $1; $vector = $2; } |
| 747 | else |
| 748 | { die "what even?"; } |
| 749 | } |
| 750 | |
| 751 | ## Add the necessary output to the test chunk. |
| 752 | if (!defined $vars) { next LINE; } |
| 753 | elsif (ref($vars) eq 'CODE') { $vars->(\$testout{$test}, @f); } |
| 754 | else { |
| 755 | die "wrong number of fields reading `$input'" unless @f == @$vars; |
| 756 | for (my $i = 0; $i < @f; $i++) |
| 757 | { $testout{$test} .= "$vars->[$i] $f[$i]\n"; } |
| 758 | } |
| 759 | $testout{$test} .= "\n"; |
| 760 | } |
| 761 | |
| 762 | ## Done with this file. |
| 763 | close $in; |
| 764 | } |
| 765 | |
| 766 | ## Write the output. |
| 767 | open my $out, ">", "$to.new"; |
| 768 | print $out "### " . $filehead . |
| 769 | "\t" x ((67 - length $filehead)/8) . |
| 770 | "-*-conf-*-\n"; |
| 771 | print $out "### Extracted from Catacomb.\n"; |
| 772 | OUT: for (my $i = 0; $i < @$varmap; $i += 2) { |
| 773 | next OUT unless defined $varmap->[$i + 1]; |
| 774 | my $test = $varmap->[$i]; |
| 775 | exists $testout{$test} or die "missing test `$test'"; |
| 776 | (my $chunk = $testout{$test}) =~ s/\n\n$/\n/; |
| 777 | print $out "\n"; |
| 778 | print $out "###" . "-" x 74 . "\n"; |
| 779 | print $out "test " . $test . "\n\n"; |
| 780 | print $out $chunk; |
| 781 | } |
| 782 | close $out; rename "$to.new", "$to"; |
| 783 | } |
| 784 | |
| 785 | ###-------------------------------------------------------------------------- |
| 786 | ### Main program. |
| 787 | |
| 788 | my @WANT_C = |
| 789 | ("math/qfarith.h", |
| 790 | "math/f25519.c", "math/f25519.h", |
| 791 | "math/fgoldi.c", "math/fgoldi.h", |
| 792 | "math/montladder.h", |
| 793 | "math/scaf.c", "math/scaf.h", |
| 794 | "math/scmul.h", |
| 795 | "pub/x25519.c", "pub/x25519.h", |
| 796 | "pub/ed25519.c", "pub/ed25519.h", |
| 797 | "pub/x448.c", "pub/x448.h", |
| 798 | "pub/ed448.c", "pub/ed448.h", |
| 799 | "symm/keccak1600.c", "symm/keccak1600.h", |
| 800 | "symm/sha3.c", "symm/sha3.h" |
| 801 | ); |
| 802 | |
| 803 | sub hack_pickn ($$@) { |
| 804 | my ($out, @f) = @_; |
| 805 | |
| 806 | die "want three fields" unless @f == 3; |
| 807 | my @v = split ' ', $f[0]; |
| 808 | for (my $i = 0; $i < @v; $i++) { $$out .= "v\[$i] $v[$i]\n"; } |
| 809 | $$out .= "i $f[1]\n"; |
| 810 | $$out .= "z $f[2]\n"; |
| 811 | } |
| 812 | |
| 813 | my @fieldish_test = |
| 814 | ("add" => ["x", "y", "z"], |
| 815 | "sub" => ["x", "y", "z"], |
| 816 | "neg" => ["x", "z"], |
| 817 | "condneg" => ["x", "m", "z"], |
| 818 | "pick2" => ["x", "y", "m", "z"], |
| 819 | "pickn" => \&hack_pickn, |
| 820 | "condswap" => ["x", "y", "m", "xx", "yy"], |
| 821 | "mulconst" => ["x", "a", "z"], |
| 822 | "mul" => ["x", "y", "z"], |
| 823 | "sqr" => ["x", "z"], |
| 824 | "inv" => ["x", "z"], |
| 825 | "quosqrt" => ["x", "y", "z0", "z1"], |
| 826 | "sub-mulc-add-sub-mul" => ["u", "v", "a", "w", "x", "y", "z"]); |
| 827 | |
| 828 | my @WANT_TEST = |
| 829 | (["math/t/f25519"] => \@fieldish_test, |
| 830 | ["math/t/fgoldi"] => \@fieldish_test, |
| 831 | ["pub/t/x25519"] => ["x25519" => ["x", "Y", "Z"], |
| 832 | "x25519-mct" => ["x", "Y", "n", "Z"]], |
| 833 | ["pub/t/x25519.slow"] => ["x25519-mct" => ["x", "Y", "n", "Z"]], |
| 834 | ["=Test vectors for Ed25519.", "!ed25519", |
| 835 | "ed25519djb:pub/t/ed25519.djb", |
| 836 | "pub/t/ed25519.local"] |
| 837 | => ["pubkey" => ["a", "A"], |
| 838 | "sign" => ["a", "m", "sig"], |
| 839 | "verify" => ["A", "m", "sig", "rc"], |
| 840 | "sign-ctx" => ["a", "ph", "ctx", "m", "sig"], |
| 841 | "verify-ctx" => ["A", "ph", "ctx", "m", "sig", "rc"]], |
| 842 | ["pub/t/x448"] => ["x448" => ["x", "Y", "Z"], |
| 843 | "x448-mct" => ["x", "Y", "n", "Z"]], |
| 844 | ["pub/t/x448.slow"] => ["x448-mct" => ["x", "Y", "n", "Z"]], |
| 845 | ["pub/t/ed448"] => ["pubkey" => ["a", "A"], |
| 846 | "sign" => ["a", "ph", "ctx", "m", "sig"], |
| 847 | "verify" => ["A", "ph", "ctx", "m", "sig", "rc"]], |
| 848 | ["symm/t/keccak1600"] => ["p" => ["x", "n", "z"]], |
| 849 | ["!sha3", |
| 850 | "sha3:symm/t/SHA3_224ShortMsg.rsp", |
| 851 | "sha3:symm/t/SHA3_224LongMsg.rsp", |
| 852 | "sha3:symm/t/SHA3_224Monte.rsp", |
| 853 | "sha3:symm/t/SHA3_256ShortMsg.rsp", |
| 854 | "sha3:symm/t/SHA3_256LongMsg.rsp", |
| 855 | "sha3:symm/t/SHA3_256Monte.rsp", |
| 856 | "sha3:symm/t/SHA3_384ShortMsg.rsp", |
| 857 | "sha3:symm/t/SHA3_384LongMsg.rsp", |
| 858 | "sha3:symm/t/SHA3_384Monte.rsp", |
| 859 | "sha3:symm/t/SHA3_512ShortMsg.rsp", |
| 860 | "sha3:symm/t/SHA3_512LongMsg.rsp", |
| 861 | "sha3:symm/t/SHA3_512Monte.rsp", |
| 862 | "sha3:symm/t/SHAKE128ShortMsg.rsp", |
| 863 | "sha3:symm/t/SHAKE128LongMsg.rsp", |
| 864 | "sha3:symm/t/SHAKE128VariableOut.rsp", |
| 865 | "sha3:symm/t/SHAKE256ShortMsg.rsp", |
| 866 | "sha3:symm/t/SHAKE256LongMsg.rsp", |
| 867 | "sha3:symm/t/SHAKE256VariableOut.rsp", |
| 868 | "symm/t/sha3.local"] |
| 869 | => ["sha3-224-hex" => ["m", "h"], |
| 870 | "sha3-224-mct" => ["n", "m", "h"], |
| 871 | "sha3-256-hex" => ["m", "h"], |
| 872 | "sha3-256-mct" => ["n", "m", "h"], |
| 873 | "sha3-384-hex" => ["m", "h"], |
| 874 | "sha3-384-mct" => ["n", "m", "h"], |
| 875 | "sha3-512-hex" => ["m", "h"], |
| 876 | "sha3-512-mct" => ["n", "m", "h"], |
| 877 | "shake128" => ["m", "h"], |
| 878 | "shake256" => ["m", "h"], |
| 879 | "cshake128" => ["func", "perso", "m", "h"], |
| 880 | "cshake256" => ["func", "perso", "m", "h"], |
| 881 | "kmac128" => undef, |
| 882 | "kmac256" => undef]); |
| 883 | |
| 884 | chomp ($DONOR_VERSION = capturex @with_dir, $DONOR_DIR, |
| 885 | "git", "describe", "--abbrev=4", "--dirty=+"); |
| 886 | chomp ($DONOR_REVISION = capturex @with_dir, $DONOR_DIR, |
| 887 | "git", "rev-parse", "HEAD"); |
| 888 | |
| 889 | for my $f (@WANT_C) { |
| 890 | (my $base = $f) =~ s{^.*/}{}; |
| 891 | note_path $f, $base; |
| 892 | convert_c "$DONOR_DIR/$f", $base; |
| 893 | } |
| 894 | |
| 895 | for (my $i = 0; $i < @WANT_TEST; $i += 2) { |
| 896 | my $src = $WANT_TEST[$i]; my $varmap = $WANT_TEST[$i + 1]; |
| 897 | my $base = undef; |
| 898 | my $fixed_name = 0; |
| 899 | my @in = (); |
| 900 | for my $j (@$src) { |
| 901 | if ($j =~ s/^!//) { |
| 902 | defined $base and die "too late to fix the name"; |
| 903 | $base = $j; $fixed_name = 1; next; |
| 904 | } elsif ($j =~ /^=/) { push @in, $j; next; } |
| 905 | my $pre = ""; |
| 906 | if ($j =~ /^([^:]*)\:(.*)$/) { $pre = $1 . ":"; $j = $2; } |
| 907 | if (!$fixed_name) { |
| 908 | (my $b = $j) =~ s{^ (?: .* /)? (.*) $}{$1}x; |
| 909 | defined $base and $base ne $b and die "huh? `$b' /= `$base'"; |
| 910 | $base = $b; |
| 911 | } |
| 912 | note_path $j, "$base-tests.in"; |
| 913 | push @in, $pre . "$DONOR_DIR/$j"; |
| 914 | } |
| 915 | convert_test \@in, "$base-tests.in", $varmap; |
| 916 | } |
| 917 | |
| 918 | commit_changes(); |