This is a proof-of-concept fingerprinting tool for testing Bitcoin issue #2757. It attempts to fingerprint a node with a difficulty-1 block. For up-to-date nodes, a higher difficulty block would be required (but still very feasable to mine even on one GPU machine). See further information on https://github.com/bitcoin/bitcoin/issues/2757.

fingerprint.pl

#!/usr/bin/perl -w
use strict;
use IO::Socket;
use Digest::SHA qw(sha256);

$SIG{ALRM} = sub {print "Timed out waiting for response... no fingerprint detected.\n";exit(1)};

# this is an orphaned difficulty-1 block at height 1001, with a timestamp in
# October 2013.  in practice you could generate a unique block for each
# individual peer you wanted to fingerprint.  this block will successfully
# fingerprint nodes up until a certain checkpoint (168000 at time of writing),
# at which point you need to generate higher PoW blocks to successfully fingerprint.
# To determine the PoW required to fingerprint an up-to-date node, look at the
# ComputeMinWork function in bitcoin's main.cpp, and pass it the latest
# checkpoint + a current timestamp.  Note that the amount of work required drops
# by a factor of 4 every 2 weeks, until a new checkpoint is put in place.
our $FPR_HASH='00000000f8c2fcc533055000181c13406bfb540dec84cd0f09188745669149ff';
our $FPR_BLOCK='0200000009edf646d13d2a7e1da8bdad14d249b037eccd8af23aa704379837c900000000a9a5eeffdd6268b2734ae89dac664f49deb320c28c6981675eb31df8f328f903229e0b52ffff001df3273c5d0101000000010000000000000000000000000000000000000000000000000000000000000000ffffffff0c02e9030101062f503253482fffffffff0100f2052a01000000232102b93b8f4b02c6f4ea0adced4b07887e30a81415df4fcb62727736a1dec9376c90ac00000000';


sub netaddr {
  my $addr = shift;
  my $port = shift;
  my $includeTimestamp = shift;

  my $netaddr = '';
  if ($includeTimestamp) {
    $netaddr .= pack('q', time()); #timestamp
  }

  $netaddr .= pack('q', 1); #NODE_NEWORK
  $netaddr .= $addr;
  $netaddr .= pack('n', $port);

  return $netaddr;
}

sub recvmsg {
  our $sock;
  #read the message header
  my ($header, $body);
  alarm(15);
  $sock->recv($header, 24);
  return undef if (!length($header));
  my(undef, $command, $length, $checksum) = unpack('VZ12Va4', $header);
  # receive the msg body
  if ($length > 0) {
    my $toread = $length;
    my $buf;
    while ($toread) {
      $sock->recv($buf, $toread);
      return undef if (!length($buf));
      $toread -= length($buf);
      $body .= $buf;
    }
    if (length($body) != $length) {
      print "Received incomplete message.\n";
      exit(1);
    }
    # validate the checksum
    if (substr(sha256(sha256($body)),0,4) ne $checksum) {
      print "Received bad message checksum.. aborting.\n";
      exit(1);
    }
  }
  print "<= Received message: $command\n";
  alarm(0);
  return ($command, $body);
}

sub sendmsg {
  our $sock;
  my $command = shift;
  my $payload = shift;
  our ($myaddr, $peeraddr, $myport, $peerport);

  my $pad = 12 - length($command);
  my $msg = pack('V', 0xD9B4BEF9) #magic
          . $command . chr(0)x$pad #command
          . pack('V', length($payload)) #length
          . substr(sha256(sha256($payload)),0,4)#checksum
          . $payload; #payload

  $sock->send($msg);
  $sock->flush();
  print "=> Sent message: $command\n";
}

sub send_version {
  our ($peeraddr,$peerport,$myaddr,$myport);

  my $payload = pack('V', 70001) #version
               .pack('q', 1)#NODE_NEWORK
               .pack('q', time())#timestamp
               .netaddr($peeraddr,$peerport,0)#remote address
               .netaddr($myaddr,$myport,0)#sender address
               .substr(sha256(int(rand(2<<32))),0,8) #random nonce
               .chr(0) # no user agent
               .pack('V', 1001)#our best block height
               .chr(0);#don't relay txns
  sendmsg('version', $payload);
}

sub getfpr() {
  # send a 'getdata' message, requesting our fingerprint block
  my $payload = chr(1) #requesting one object
               .pack('V', 2) #MSG_BLOCK
               .hex2uint256($FPR_HASH);
  sendmsg('getdata', $payload);
}

sub hex2uint256 {
  my $hexstr = shift;
  my $reverse = '';
  for (my $i = 62; $i >= 0; $i-=2) {
    $reverse .= substr($hexstr,$i,2);
  }
  return pack('H64', $reverse);
}

sub sendinv() {
  my $payload = chr(1) # 1 object
               .pack('V', 2) #MSG_BLOCK
               .hex2uint256($FPR_HASH);
  sendmsg('inv', $payload);
}

sub checkblock {
  my $body = shift;
  my $blockheader = substr($body, 0, 80);
  my $blockhash = unpack('H*', hex2uint256(unpack('H*', sha256(sha256($blockheader)))));
  if ($blockhash eq $FPR_HASH) {
    print "Node has fingerprint ($FPR_HASH).\n";
    exit;
  }
}

sub sendfpr {
  my $block = pack('H*', $FPR_BLOCK);
  sendmsg('block', $block);
}

sub handle_getdata {
  my $body = shift;
  if (unpack('C', substr($body, 0, 1)) == 1) {
    my $reqhash = unpack('H*', hex2uint256(unpack('H64', substr($body,5,32))));
    if ($reqhash eq $FPR_HASH) {
      print "Fingerprint requested. Sending...\n";
      sendfpr();
      # if we disconnect too soon, the node might not process and accept this block in time.
      # i haven't gotten to the bottom of this, but i suspect the message queue
      # gets cleared and not processed if the peer disconnects.
      sleep(10);
      print "Fingerprint sent. Re-run this script to check if node accepted it.\n";
      exit();
    }
  }
}

if (!@ARGV) {
  print STDERR "Usage: $0 <ip-addr> [port]\n";
  exit(1);
}

our $sock = new IO::Socket::INET(
  PeerAddr => $ARGV[0],
  PeerPort => defined($ARGV[1]) ? $ARGV[1] : 8333,
  Proto => 'tcp'
) or die("Couldn't connect to host: $!\n");

# local and remote addresses, in ipv4-mapped ipv6 format
our $myaddr = pack('H*', '00000000000000000000FFFF').$sock->sockaddr();
our $peeraddr = pack('H*', '00000000000000000000FFFF').$sock->peeraddr();
our $myport = $sock->sockport();
our $peerport = $sock->peerport();

send_version();

#receive msg
my ($command, $body);
while (($command, $body) = recvmsg()) {
  if (!defined($command)) {
    print "Receive failed (possibly we're banned if previous fingerprint attempt had too low PoW). No fingerprint detected.\n";
    exit(1);
  }
  if ($command eq 'version') {
    print "Peer is version: " . unpack('V', substr($body,0,4)) . "\n";
    # send verack
    sendmsg('verack', '');
  } elsif ($command eq 'block') {
    checkblock($body);
  } elsif ($command eq 'getdata') {
    handle_getdata($body);
  } else {
    getfpr();
    sendinv();
  }
}