package My::MD4;
use v5.24;
use warnings;
use experimental 'signatures';
no warnings 'experimental::signatures';
use List::Util 'reduce';

use constant B32M => 0XFFFFFFFF;

sub new ($package, %args) {
   my $self = bless {
      A => 0x67452301,
      B => 0xEFCDAB89,
      C => 0x98BADCFE,
      D => 0x10325476,
      ml => 0,           # message length, in bits
      left => '',        # leftover not reaching 512 bytes
      %args, # this can override anything
   }, ref($package) || $package;
   if (defined(my $starter = delete $self->{starter})) {
      $self->@{qw< A B C D >} = unpack 'V4', pack 'H*', $starter;
   }
   return $self;
}

sub clone ($self) { return $self->new($self->%*) }

sub hex_digest ($self) {
   my $copy = $self->clone->add($self->padding);
   die "residuals\n" if length($copy->{left});
   unpack 'H*', pack 'V4', $copy->@{qw< A B C D >};
}

sub padding ($self, $length = undef) {
   $length //= $self->{ml};
   my $l512 = (1 + $length) % 512;
   my $n_zeros = 448 - $l512 + ($l512 <= 448 ? 0 : 512);
   return join '', "\x80", "\x00" x ($n_zeros / 8),
      pack 'V2', $length & 0xFFFFFFFF, $length >> 32;
}

sub _append_padding ($self) {
   my $length = $self->{ml};
   my $l512 = (1 + $length) % 512;
   my $n_zeros = 448 - $l512 + ($l512 <= 448 ? 0 : 512);
   $self->add("\x80", "\x00" x ($n_zeros / 8),
      pack 'V2', $length & 0xFFFFFFFF, $length >> 32);
   return $self;
}

sub d {
   my $format = join '  ', ('%08x') x @_;
   printf {*STDOUT} $format . "\n", @_;
}

sub add ($self, @data) {
   state $F = sub ($x, $y, $z) { ($x & $y) | ((B32M ^ $x) & $z) };
   state $G = sub ($x, $y, $z) { ($x & $y) | ($x & $z) | ($y & $z) };
   state $H = sub ($x, $y, $z) { $x ^ $y ^ $z };

   my $data = join '', @data;
   $self->{left} .= $data;
   $self->{ml} += 8 * length($data);

   my (@h, @w); # working arrays to ease iteration via sub $Z
   my $apply_op = sub ($op, $add, @ins) {
      for my $in (@ins) {
         $in->[0] = [ map { ord($_) - ord('A') } split m{}mxs, $in->[0] ]
            unless ref $in->[0];
         my ($idxs, $k, $s) = $in->@*;
         my ($ai, @bcdi) = $idxs->@*;
         my $sum = $h[$ai] + $op->(@h[@bcdi]) + $w[$k] + $add;
         $h[$ai] = left($sum & B32M, $s);
      }
   };

   @h = $self->@{qw< A B C D >};
   while (length($self->{left}) >= 512 / 8) { # take 512-bits chunks

      # initialize for chunk
      my @hh = @h;
      @w = map {
         my $word = substr $self->{left}, 0, 32 / 8, '';
         unpack 'V', $word;
      } 0 .. 15;

      $apply_op->($F, 0x00000000,
         [ABCD =>  0,  3],  [DABC =>  1,  7],  [CDAB =>  2, 11],  [BCDA =>  3, 19],
         [ABCD =>  4,  3],  [DABC =>  5,  7],  [CDAB =>  6, 11],  [BCDA =>  7, 19],
         [ABCD =>  8,  3],  [DABC =>  9,  7],  [CDAB => 10, 11],  [BCDA => 11, 19],
         [ABCD => 12,  3],  [DABC => 13,  7],  [CDAB => 14, 11],  [BCDA => 15, 19],
      );

      $apply_op->($G, 0x5A827999,
        [ABCD =>  0,  3],  [DABC =>  4,  5],  [CDAB =>  8,  9],  [BCDA => 12, 13],
        [ABCD =>  1,  3],  [DABC =>  5,  5],  [CDAB =>  9,  9],  [BCDA => 13, 13],
        [ABCD =>  2,  3],  [DABC =>  6,  5],  [CDAB => 10,  9],  [BCDA => 14, 13],
        [ABCD =>  3,  3],  [DABC =>  7,  5],  [CDAB => 11,  9],  [BCDA => 15, 13],
      );

      $apply_op->($H, 0x6ED9EBA1,
        [ABCD =>  0,  3],  [DABC =>  8,  9],  [CDAB =>  4, 11],  [BCDA => 12, 15],
        [ABCD =>  2,  3],  [DABC => 10,  9],  [CDAB =>  6, 11],  [BCDA => 14, 15],
        [ABCD =>  1,  3],  [DABC =>  9,  9],  [CDAB =>  5, 11],  [BCDA => 13, 15],
        [ABCD =>  3,  3],  [DABC => 11,  9],  [CDAB =>  7, 11],  [BCDA => 15, 15],
      );

      # update for next chunk or result
      $h[$_] = ($h[$_] + $hh[$_]) & B32M for 0 .. $#h;
   }
   $self->@{qw< A B C D >} = @h;

   return $self;
}

sub left ($n, $amount) {
   (($n << $amount) | ($n >> (32 - $amount))) & B32M;
}

1;

#!/usr/bin/env perl
use v5.24;
use warnings;
use experimental 'signatures';
no warnings 'experimental::signatures';

use File::Basename 'dirname';
use lib dirname(__FILE__);
use CryptoPals ':all';

# This is what we have access to, granted by the "server" and provided
# back to us
my $original_permissions = 'comment1=cooking%20MCs;userdata=foo;' .
   'comment2=%20like%20a%20pound%20of%20bacon';
my $original_mac = MD4_MAC_ps_generate($original_permissions);

# This is what we want to append
my $sneaked_permission = ';admin=true';

# Now we "just" have to try out different secret key lengths
my $original_length = length $original_permissions;
my $key_length = 0;

while ('necessary') {
   my $length_so_far = $key_length + $original_length;
   my $glue_padding = My::MD4->padding($length_so_far * 8);
   $length_so_far += length $glue_padding;

   # Let's "extend" the MAC we got
   my $forger =
      My::MD4->new(starter => $original_mac, ml => $length_so_far * 8);
   my $forged_mac = $forger->add($sneaked_permission)->hex_digest;

   # This is the corresponding full permissions we're forging
   my $forged_permissions =
      $original_permissions . $glue_padding . $sneaked_permission;

   last if MD4_MAC_ps_check($forged_permissions, $forged_mac);
   ++$key_length;
}

say "We're in! Secret key length: $key_length "
   . "(pssst! key was '@{[ the_key() ]}', but we didn't need it!)";

sub MD4_MAC_prefix_secret ($key, $message) {
   return My::MD4->new->add($key, $message)->hex_digest;
}

sub MD4_MAC_ps_generate ($message) {
   return MD4_MAC_prefix_secret(the_key(), $message);
}

sub MD4_MAC_ps_check ($message, $authenticator) {
   return MD4_MAC_ps_generate($message) eq $authenticator;
}

sub the_key() { state $key = random_text_word() }