lasercode.pl

lasercode.pl

#!/usr/bin/perl
# lasercode, a single-user IRC proxy for transparently handling encrirc-like 
# encryption.
# Authors: #laserboy

# Try to aim for backwards compatability in some fashion
# Think portability and reusability

# BUGS: 
# - TOPIC is supported, but the server truncs the message to 160 chars
#   (and so truncs the key)
# - Message encoder loop doesn't split the message into chunks;
#   it simply truncates the string, losing any additional(>80) characters.

# Thoughts: 
# - I'd really like to see IRCSRP v2.0 being implemented instead of encrirc.
# - Won't work in windas: "Non-blocking and timeouts (which are based on non-
#   blocking) are not supported on Win32, because the underlying 
#   IO::Socket::INET does not support non-blocking on this platform."
 
# Main problems with encrirc which we want to address:
# - It seems like a lot of the cryptographic code is bodged
# - ACTIONs not supported (breaks client output)
# - TOPIC can't be encrypted (no handler)
# - No builtin word-wrapping segmenter (long sentences are simply truncated)
# - Securely store keys?? (breaks compatability)

# Resources:
# - http://www.hping.org/encrirc/ and
#   the ENCRYPTION DETAILS segment in its README file.
# - http://blog.bjrn.se/2009/01/proposal-for-better-irc-encryption.html
# - http://en.wikipedia.org/wiki/HMAC
# - http://en.wikipedia.org/wiki/Blowfish_%28cipher%29
# - http://kobesearch.cpan.org/htdocs/Crypt-CBC/Crypt/CBC.pm.html
# - http://en.wikipedia.org/wiki/Cipher_block_chaining#Cipher-block_chaining_.28CBC.29

# lasercode. Why the hell isn't it called lasercrypt? Or laserencr? This code 
# is heavily inspired from encrirc 0.1 (www.hping.org/encrirc/).

# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU 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 General Public License for more details.

# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

use warnings;
use strict;
use utf8;

use encoding 'utf8';

use Parse::IRC;
use Digest::MD5 qw(md5 md5_hex md5_base64);
use Digest::HMAC qw(hmac hmac_hex);
use Crypt::Random qw(makerandom_octet); 
use Crypt::Blowfish;
use Crypt::CBC;
use IO::Select;
use IO::Socket;
use IO::Socket::SSL;
use EV;
use Getopt::Long;
#use Data::Dumper;
use File::stat;

################################################################################
# Common variables

use constant {
	VERSION	           	=> '0.0.1', 
	DEFAULT_SERVER_ADDR	=> 'irc.efnet.pl',
	DEFAULT_SERVER_PORT	=> 6667,
	DEFAULT_SERVER_SSL	=> 0,
	DEFAULT_CLIENT_PORT	=> 8111,
	DEFAULT_DEBUG		=> 1,
	# Files
	DEFAULT_LOG_FILE	=> 'lasercode.log',
	DEFAULT_KEY_FILE	=> $ENV{HOME} . "/.lasercode.keys",
	KEYFILE_CHECK_INTERVAL  => 10,
	# IRC messages
	PARAM_ACTION	        => chr(1) . 'ACTION ',
	PLAINTEXT_IDENTIFIER	=> '+p',
	MSG_HEADER	        => '>encrirc<',                           # Test
	MSG_SEPARATOR		=> '|',
	# Cryptographic
	BITS_KEY		=> 256, # 8 * 32
	BITS_KEYID		=> 128, # 8 * 16
	BITS_IV			=> 128, # 8 * 16
	# Misc constants
	DEFAULT_TIMEOUT         => 1, #XXX for the selector. Don't set to 0!
	LOG_MODE_FILE           => 1,
	LOG_MODE_STDOUT         => 2,
	LOG_MODE_ALL            => 3,
	AUTOFLUSH_MODE	        => 1,
};

my %opt = (
	server_addr => DEFAULT_SERVER_ADDR,
	client_port => DEFAULT_CLIENT_PORT,
	server_port => DEFAULT_SERVER_PORT,
	server_ssl  => DEFAULT_SERVER_SSL,
	log_file    => DEFAULT_LOG_FILE,
	key_file    => DEFAULT_KEY_FILE,

	new_key     => '',
	gen_key     => '',
	debug       => DEFAULT_DEBUG,
	help        => '',
);

my ($selector, $listener, $sock_client, $sock_server);
my (%keys, %ids, %tokens);
my $last_mtime = 0;

################################################################################
# IRC-specific

sub irc_notice {
	my ($sock, $msg) = @_;
	print $sock ":laser NOTICE AUTH: " . $msg . "\r\n";
}

################################################################################
# General subroutines

sub display_tagline {
	printf("\nlasercode v%s, " . 
	       "a single-user IRC proxy for transparently handling\n" .
	       "encrirc-like encryption.\n\n",
	       VERSION);
}

sub display_help {
	display_tagline();

	print "Options:\n";

	for (keys %opt) {
		my $beg = "    --$_";
		my $end = $opt{$_} eq '' ? '' : "(default: $opt{$_})";
		my $padding = ' 'x((80 - length $end) - length $beg);
		print "$beg$padding$end\n";
	}

	print "\n";
}

sub log_print {
	my ($message, $mode) = @_;

	if(($mode & LOG_MODE_FILE) == LOG_MODE_FILE) {
		open LOG, '>>', $opt{log_file}
			or die "Can't open \"$opt{log_file}\": \"$!\"";
		print LOG $message;
		close LOG;
	}

	if(($mode & LOG_MODE_STDOUT) == LOG_MODE_STDOUT) {
		print $message;
	}

}
	
sub dbg_print {
	log_print("DBG: @_", LOG_MODE_ALL) if $opt{debug};
}

sub get_opts_human {
	my $tmp;
	for (keys %opt) {
		$tmp .= "$_ = $opt{$_}\n" if $opt{$_} ne '';
	}
	return $tmp;
}


sub client_init {
	undef $sock_client;
	undef $listener;

	$listener = new IO::Socket::INET(Listen    => 1,
					 Blocking  => 0,
					 LocalHost => 'localhost',
					 LocalPort => $opt{client_port},
					 Proto     => 'tcp',
					 ReuseAddr => 1
					);

	unless($listener) {
		log_print("Can't init client socket: \"$@\"\n", LOG_MODE_ALL);
		die;
	}

	$listener->autoflush(AUTOFLUSH_MODE);

}

sub server_init {
	undef $sock_server;

	$sock_server = new IO::Socket::INET(PeerAddr => $opt{server_addr},
					    PeerPort => $opt{server_port},
					    Proto    => 'tcp',
					    Blocking => 0
					   );
	# Upgrade socket to SSL if needed.
	if ($opt{server_ssl}) {
		IO::Socket::SSL->start_SSL($sock_server);
	}
	unless($sock_server) {
		log_print("Can't init server socket: \"$@\"\n", LOG_MODE_ALL);
		die;
	}
	
	$sock_server->autoflush(AUTOFLUSH_MODE);

	log_print("Initialized server(irc) socket.\n", LOG_MODE_ALL);
}

sub sock_close {
	for (@_) {
		next if ! ${$_};
		$selector->remove(${$_});
		dbg_print("Close ${$_}\n");
		# The below line *CRASHES* the server completely by:
		# DBG: Close *Symbol::GEN3
		# Can't call method "close" without a package or object reference
		#${$_}->close();
		undef ${$_};
	}
}


################################################################################
# Encryption-related subroutines

sub poll_keyfile {
	#dbg_print("Polling keyfile mtime\n");

	my $current_mtime = stat($opt{key_file})->mtime;

	return if $current_mtime == $last_mtime;

	%keys = get_key_hash($opt{key_file});
}
	
sub save_key_hash {
	my $filename = shift;

	open KEYFILE, '>', $filename 
		or die "Can't open key file \"$filename\": $!";

	foreach my $key (keys %keys) {
		my @vals = (@{$keys{$key}});
		#shift @vals; #  Skip id(md5) created during runtime.
		dbg_print("Storing $key @vals\n");
		print KEYFILE "$key @vals\n";
	}

	close KEYFILE;
	
	dbg_print('Keys saved: ' . (keys %keys). " \n");
}

sub keygen_dialog {
	my @new_tokens = split ' ', shift;

	# Find any existing tokens
	my $conflict = 0;

	foreach my $old_tokens (values %keys) {
		foreach my $a (@{$old_tokens}) {
			foreach my $b (@new_tokens) {
				if($a eq $b) {
					log_print("Token \"$a\" already exists".
						  " in the keyring file.\n",
						  LOG_MODE_ALL);
					$conflict = 1;
					last;
				}
			}
		}
	}

	if($conflict) {
		log_print("Aborting due to above conflicts.\n", LOG_MODE_ALL);
		die;
	}
	
	log_print("Generating new key for: @new_tokens ".
		  "(do stuff if it's slow)\n", LOG_MODE_ALL);
	
	my $key = get_random_key();

	$keys{$key} = (\@new_tokens);

	print "\n\t\"$key @new_tokens\"\n\n";
	
	save_key_hash($opt{key_file});

}

sub get_key_hash {
	my $filename = shift;
	my %keys;

	open KEYFILE, '<', $filename 
		or die "Can't open key file \"$filename\": $!";

	while (<KEYFILE>) {
		my @args = split ' ';
		my $key = pack "H*", shift @args;

		# Skip bad entries (don't die; we're hosting connections)
		if(@args < 1) {
			log_print("Corrupt keyfile line \"@args\"",
				  LOG_MODE_ALL);
			last;
		}

		if(length($key) != (BITS_KEY / 8)) {
			log_print("Invalid key \"$key\" in keyring\n",
				  LOG_MODE_ALL);
			last;
		}

		# The first arg is our id, based on the key itself
		$ids{"@args"} = get_key_id($key);

		$keys{$key} = \@args;

	}

	close KEYFILE;
	
	dbg_print('Keys loaded: ' . (keys %keys). " \n");

	$last_mtime = stat($opt{key_file})->mtime;

	return %keys; # Can be read by @{$_{key}
}

sub get_random_key {
	return unpack 'H*', makerandom_octet(Size     => BITS_KEY - 8, 
					     Strength => 1,
					     Uniform  => 1);
}

sub get_key_id {
	return substr md5_hex(shift), 0, (BITS_KEYID / 8);
}

sub get_random_iv { # iv = initialization vector
	my $hex = md5_hex(makerandom_octet(Size     => BITS_IV - 8,
					   Strength => 0,
					   Uniform  => 1));
	return substr $hex, 0, (BITS_IV / 8);
}

sub get_key_by_id {
	my $id = shift;

	foreach my $key (keys %keys) {
		my $vals = $keys{$key};
		my $key_id = $ids{"@$vals"};

		if($key_id eq $id) {
			dbg_print("Found key for id \"$id\": \"$key\"\n");
			return $key;
		}
	}

	dbg_print("Can't find key for id \"$id\"\n");
	
	return undef;
}

sub get_key_by_target {
	my $target = "\Q$_[0]\E";

	dbg_print("Attempting to fetch key for target \"$target\"\n");

	foreach my $key (keys %keys) {
		my $vals = $keys{$key};

		foreach my $entry (@$vals) {
			my $esc_entry = $entry; # Hack

			$esc_entry = "\Q$entry\E";
			$esc_entry =~s/\\\*/.*?/g;

			dbg_print("get_key_by_target(): cmp " .
				  "target(\"$target\"), entry(\"$esc_entry\")\n");

			if($target =~m/$esc_entry/) {
				dbg_print("KEY MATCH for \"$target\"\n");
				#return get_key_by_id($ids{"@$vals"});
				return $key;
			}
		}
	}

	return undef;
}

sub get_blowfish_token {
	my ($key, $iv) = @_;

	dbg_print("get_blowfish_token(\"$key\", \"$iv\");\n");

	$key = pack "H*", $key;
	$iv  = pack "H*", $iv;

	dbg_print("Unpacked key: \"$key\"\n");
	dbg_print("Unpacked  iv: \"$iv\"\n");
	dbg_print("IV length: " . length($iv) . "\n");
	
	if(! exists $tokens{$key}) {
		dbg_print("No token for $key, creating one.\n");

		$tokens{$key} = new Crypt::CBC('-key'     => $key,
					       '-iv'      => $iv,
					       '-cipher'  => 'Blowfish',
					       '-header'  => 'none',
					       '-keysize' => (BITS_KEY / 8));
	}

	dbg_print("Got CBC object $tokens{$key}\n");

	return $tokens{$key};
}

sub raw_encrypt {
	my($msg, $key, $iv) = @_;
	dbg_print("raw_encrypt(\"$msg\", \"$key\", \"$iv\");\n");

	my $len = length $msg;

	if($len > 80) { # FIXME
		dbg_print("FIXME: Truncating $len string to 80!\n");
		$msg = substr $msg, 0, 80;
	}else{ 
		# Space-pad to 80
		$msg .= ' 'x(80 - $len);
	}

	# Get message digest
	my $digest = hmac_hex($msg, $key, \&md5);
	dbg_print("Digest: \"$digest\"\n");

	# Get (or generate) token
	my $bf = get_blowfish_token($key, $iv);

	dbg_print("Data: \"$msg(($digest))\"\n");
	my $data = unpack "H*", $bf->encrypt($msg . $digest);
	return $data;
}

sub raw_decrypt {
	my ($msg, $key, $iv) = @_;

	$msg = pack "H*", $msg;
	
	my $bf = get_blowfish_token($key, $iv);
	my $data = $bf->decrypt($msg);

	my $hmac_a = substr $data, -32;     # Last 32b of msg is the hmac
	$data = substr $data, 0, -32;       # Chop off the hmac
	dbg_print("Data: \"$data\"\n");

	my $hmac_b = hmac_hex($data, $key, \&md5); # Gen hmac to compare with
	dbg_print("Extracted digest: \"$hmac_a\"\n");
	dbg_print("Generated digest: \"$hmac_b\"\n");

	if($hmac_a ne $hmac_b) {
		dbg_print("hmac($hmac_a) invalid! Attack in act?\n",
			LOG_MODE_ALL);
		return;
	}
	
	$data =~s/\s+$//; # rtrim

	return $data;
}

sub msg_encrypt {
	my ($msg, $key) = @_;

	dbg_print("msg_encrypt(\"$msg\", \"$key\")\n");

	my $iv = get_random_iv();
	my $id = get_key_id($key);

	return sprintf("%s%s%s%s%s",
		       $id, MSG_SEPARATOR,
		       $iv, MSG_SEPARATOR,
		       raw_encrypt($msg, $key, $iv));
}

sub msg_decrypt {

	# A really ugly hack. For an unknown reason, simply escaping '|'
	# will result in utter chaos; split will think $sep == undef,
	# splitting the string by each character. This is exactly
	# equivalent to doing that, but does it programmatically.
	my $tmp = MSG_SEPARATOR;
	$tmp ="\Q$tmp\E";
	my @segs = split $tmp, shift;
	undef $tmp;

	if(@segs != 3) {
		log_print("Bad message format \"@segs\"\n",
			  LOG_MODE_ALL);
		return;
	}

	my ($id, $iv, $msg) = @segs;
	
	my $key = get_key_by_id($id);
	
	if(! $key) {
		log_print("Can't find key for '$id'\n", LOG_MODE_ALL);
		return;
	}

	return raw_decrypt($msg, $key, $iv);
}

sub parse_buffer {
	my ($sock, $buf) = @_;

	my @queue = split /(\r\n)/, $buf;

#	undef $buf;
	for my $line (@queue) {

		my $parsed = parse_irc($line);

		# Skip parsing if it's bullshit.
		if(! defined $parsed) {
			# next unless defined $parsed;
			#dbg_print("Can't parse: \"$line\"\n");
			next;
		}

		my $cmd = $parsed->{command};
			
		# Skip parsing if it's irrelevant:
		next if $cmd ne 'PRIVMSG' && 
			$cmd ne 'TOPIC';

		my $args = $parsed->{params};

		# Skip if we lack target + message.
		next if @$args < 2;

		# Get to work..
		my ($target, $msg) = @$args;

		# Check if it's an action
		my $is_action = 0;

		if(substr($msg, 0, length(PARAM_ACTION)) eq PARAM_ACTION) {
			$is_action = 1 if $cmd eq 'PRIVMSG';
		}

		# Pick out data we can encrypt/decrypt
		my $old = $is_action ? 
			substr $msg, length(PARAM_ACTION), -1 :
			$msg;

		dbg_print("OLD data: \"$old\"\n");

		# See if we have a key for this target
		my $key = get_key_by_target($target);

		# If not, skip it
		unless(defined $key) {
			log_print("Can't find key for for \"$target\"\n",
				  LOG_MODE_ALL);
			next;
		}

		# Perform enc/dec
		my $new;

		if($sock == $sock_client) {
			# client->irc, encode it

			next if substr $old, 0, length(PLAINTEXT_IDENTIFIER) 
				eq PLAINTEXT_IDENTIFIER;

			$new = MSG_HEADER . msg_encrypt($old, $key);
		} else {
			# irc->client, decode it

			# Skip if header is absent
			if(substr($old, 0, length(MSG_HEADER)) ne MSG_HEADER) {
				log_print("Unencrypted message from keyholder ".
					  "\"$target\": \"$old\"",
					  LOG_MODE_ALL);
				next;
			}

			$new = msg_decrypt(substr($old, length(MSG_HEADER)), 
					   $key);
		}

		unless(defined $new) { # enc/dec failed for some reason
			log_print("Crypt failure for \"$target\"!\n",
				  LOG_MODE_ALL);
			next;
		} 

		dbg_print("CRYPT: $old -> $new\n");

		# Reassemble
		$line =~s/\Q$old\E/$new/;

	}

	# Useful for hardcore debugging..
	#my $RESULT = join '', @queue;
	#print "\n\nINPUT:\n=====\n$buf\n=====\n";
	#print "OUTPU:\n=====\n$RESULT\n=====\n\n";
	
	return join '', @queue;
}

################################################################################
# Main

# Populate commandline arguments (otherwise defaults are in effect)
my $res = GetOptions('server_addr=s' => \$opt{server_addr},
		     'server_port=s' => \$opt{server_port},
		     'server_ssl=s'  => \$opt{server_ssl},
		     'client_port=s' => \$opt{client_port},
		     'log_fil=s'     => \$opt{log_file},
		     'key_file=s'    => \$opt{key_file},
		     'gen_key=s'     => \$opt{new_key},
		     'help'          => sub {display_help(); exit;},
		     'debug'         => sub {$opt{debug} = 1},
		    );

display_tagline();
log_print("Configuration:\n" . get_opts_human() . "\n", LOG_MODE_ALL);

if(! -f $opt{key_file} && $opt{new_key} ne '') { # Assume we have no keys yet
	log_print("\nNO KEYFILE FOUND - We'll create one now (or abort now!)\n",
		  LOG_MODE_STDOUT);
	keygen_dialog($opt{new_key});
} else {
	# Load the keyring file containing hashes and channel/nick globs
	%keys = get_key_hash($opt{key_file});

	if($opt{new_key} ne '') {
		keygen_dialog($opt{new_key});
		exit;

	}
}

## T e s t c o d e ############
# This testcode tests the encrypt/decrypt + hmac check.
#$sock_client = 1;
#$sock_server = 2;
#
## XXX ENCODE 
#my $user = "#puffpuffpass";
#my $msg  = "Lol this is a test";
#my $data = ":gammy!~gam\@bolaget.se TOPIC $user :$msg\r\n";
#my $result = parse_buffer($sock_client, $data);
#print "->$result\n";
#
#print "\n\n===============================================================\n\n";
#
## XXX DECODE
#my $result = parse_buffer($sock_server, $result);
#print "$result\n";
#
#
#print "\nEXITING DUE TO HACK.\n";
#exit;
## T e s t c o d e ############

# Init client socket 
client_init();

$selector = new IO::Select;
$selector->add($listener);

# Set up timer for checking the keyfile
my $watchdog = EV::timer(KEYFILE_CHECK_INTERVAL, 
			 KEYFILE_CHECK_INTERVAL, 
			 'poll_keyfile');

log_print("Ready.\n", LOG_MODE_STDOUT);
		
my ($buf_read, $buf_write) = ('', ''); # Decl & init
my ($last_read_len, $last_write_len) = (0, 0); # Only used for debug output

while(1) {

	my @socks_read  = $selector->can_read(DEFAULT_TIMEOUT);

	foreach my $sock (@socks_read) {

		$sock->read($buf_read, 1024);
		
    		if($sock == $listener) {
			# Handle connection request

			dbg_print("Sock == Listener\n");
			if(! $sock_client) {
				# New connection 

				$sock_client = $listener->accept;
				$sock_client->autoflush(AUTOFLUSH_MODE);
				$sock_client->blocking(0);

				$selector->add($sock_client);

				log_print("Accepted $sock_client\n", 
					  LOG_MODE_FILE);

				# Start server connection
				if(! $sock_server) {
					server_init();
					$selector->add($sock_server);
				}
			}else {
				# Client already connected

				my $tmp = $listener->accept;
				irc_notice($tmp, "Proxy full.");
				sock_close(($tmp));
				log_print("Denied $sock\n", LOG_MODE_FILE);
			}
		} else {
			# Handle socket IO

			dbg_print("Sock != Listener\n");

			if($sock != $sock_client &&
			   $sock != $sock_server) {
				dbg_print("WTF???\n");
				die;
			}

			# Empty buffer = closed socket 
			if(! $buf_read) {
				# Close both sockets.
				dbg_print("Disconnecting: $sock\n");
				sock_close(\$sock_client, \$sock_server);
				last;
			}

			# Proxy message
			my $dest = 
				($sock == $sock_client) ? $sock_server : 
				                          $sock_client;

			if($opt{debug}) {
				my $from = $sock == $sock_client ?
					"client" : "server";
				my $to = $dest == $sock_client ? 
					"client" : "server";
				dbg_print("FROM $sock($from) " .
					  "TO $dest($to):\n" . 
					  "[$from]:$buf_read\n\n");
			}

			# Check if we can write yet.
			my $cwr = new IO::Select($dest);
			my @socks_write = $cwr->can_write(DEFAULT_TIMEOUT);

			# If we can't, append read buf to write buf
			if (@socks_write != 1) {
				$buf_write .= $buf_read;
				$buf_read = '';
			} else {
				# If we can, send dat shizzle and clear $buf_write
				#$dest->print($buf_write . $buf_read);
				my $t = parse_buffer($sock, 
						     $buf_write . $buf_read);
				$dest->print($t);
				undef $t;
				$buf_write = '';
			}
		}
	}

	EV::loop EV::LOOP_NONBLOCK;

	if($opt{debug}) {
		my ($read_len, $write_len) = (length $buf_read, 
					      length $buf_write);

		if($read_len != $last_read_len ||
		   $write_len != $last_write_len) {
			dbg_print(sprintf("Remaning in buffers: " .
					  "%d(read), %d(write)\n",
					  length($buf_read),
					  length($buf_write)));

		}
		
		$last_read_len = $read_len;
		$last_write_len = $write_len;
	}
}