First version

6 files changed, 246 insertions, 0 deletions

diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..d1bea80
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,5 @@
+all:
+	@echo "Supported targets: test"
+
+test:
+	prove -I. t/*.t
diff --git a/Spline/Netstring.pm b/Spline/Netstring.pm
new file mode 100644
index 0000000..e7e649f
--- /dev/null
+++ b/Spline/Netstring.pm
@@ -0,0 +1,42 @@
+package Spline::Netstring;
+
+use strict;
+use warnings;
+
+our @EXPORT = qw(
+    netstring_read
+    netstring_write
+);
+
+sub read_length($) {
+    my $fd = shift;
+    my $length;
+
+    local $/ = ':';
+    $length = <$fd>;
+    die "Cannot read netstring length" unless defined($length);
+    chomp $length;
+
+    return $length;
+}
+
+sub netstring_read($) {
+    my $fd = shift;
+    my ($length, $data);
+
+    $length = read_length($fd);
+    if (read($fd, $data, $length) == $length) {
+        (getc() eq ',') or die "Closing , missing";
+    }
+    else {
+        die 'Received only ' . length($data) . " of $length bytes";
+    }
+
+    return $data;
+}
+
+sub netstring_write($$) {
+    my ($fd, $data) = @_;
+
+    print $fd length($data).':'.$data.',';
+}
diff --git a/Spline/Socketmap.pm b/Spline/Socketmap.pm
new file mode 100644
index 0000000..df1a6a9
--- /dev/null
+++ b/Spline/Socketmap.pm
@@ -0,0 +1,65 @@
+package Spline::Socketmap;
+
+use strict;
+use warnings;
+use base qw(Net::Server::PreFork);
+
+use Spline::Netstring;
+use Spline::Srs qw( srs_forward srs_reverse );
+
+use base 'Exporter';
+our @EXPORT = qw( );
+our @EXPORT_OK = qw( );
+
+our $timeout = 10;
+our $handler = undef; 
+
+sub call_handler(@) {
+    return unless ref($handler) eq 'CODE';
+    return \&$handler(@_);
+}
+
+sub handle_request($) {
+    my $data = shift;
+
+    my ($map, $key) = split(/ /, $data, 2);
+    my $result = call_handler($map, $key);
+    if (defined $result) {
+        reply($result);
+    }
+    else {
+        reply('TEMP Protocol error');
+    }
+}
+
+sub process_request {
+    my $self = shift;
+
+    eval {
+        local $SIG{'ALRM'} = sub { die "Timed Out!\n" };
+        alarm($timeout);
+
+        handle_request(netstring_read(*STDIN));
+        alarm(0);
+    };
+    my $err = $@;
+    alarm(0);
+
+
+    if ($err) {
+        if ($err =~ /timed out/i) {
+            reply('TEMP Timeout');
+        }
+        else {
+            reply('TEMP Unknown error');
+        }
+    }
+}
+
+sub reply($) {
+    netstring_write(*STDOUT, @_);
+}
+
+1;
+
+# vim: set et ts=4:
diff --git a/Spline/Srs.pm b/Spline/Srs.pm
new file mode 100644
index 0000000..d7fc795
--- /dev/null
+++ b/Spline/Srs.pm
@@ -0,0 +1,87 @@
+package Spline::Srs;
+
+use strict;
+use warnings;
+
+use Mail::SRS;
+use Spline::Netstring;
+
+use base 'Exporter';
+our @EXPORT = qw( );
+our @EXPORT_OK = qw(
+    check_exclude
+    srs_forward
+    srs_reverse
+);
+
+our $alias = 'spline.inf.fu-berlin.de';
+our @excludes = (
+    'spline.inf.fu-berlin.de',
+    '.spline.inf.fu-berlin.de',
+    'spline.de',
+    '.spline.de',
+);
+
+my $srs = new Mail::SRS(
+    Secret     => "",
+    MaxAge     => 49,
+    HashLength => 5,
+    HashMin    => 4,
+);
+
+sub check_exclude($@) {
+    my $addr = shift;
+    my @excludes = @_;
+
+    my @parts = split(/@/, $addr);
+    my $domain = $parts[-1];
+
+    for my $exclude (@excludes) {
+        if ($exclude =~ m/^\./) {
+            return 1 if $domain =~ m/\Q$exclude\E$/;
+        }
+        else {
+            return 1 if $domain eq $exclude;
+        }
+    }
+
+    return 0;
+}
+
+sub srs_forward($) {
+    my $addr = shift;
+
+    return if check_exclude($addr, @excludes);
+    return $srs->forward($addr, $alias);
+}
+
+sub srs_reverse($) {
+    my $addr = shift;
+    return $srs->reverse($addr);
+}
+
+sub handle($$) {
+    my ($map, $key) = @_;
+    my $result;
+
+    if ($map eq 'forward') {
+        $result = srs_forward($key);
+    }
+    elsif ($map eq 'reverse') {
+        $result = srs_reverse($key);
+    }
+    else {
+        return "PERM Invalid request";
+    }
+
+    if (!defined($result)) {
+        return 'NOTFOUND ';
+    }
+    else {
+        return 'OK ' . $result;
+    }
+}
+
+1;
+
+# vim: set et ts=4:
diff --git a/srs b/srs
new file mode 100755
index 0000000..eea1711
--- /dev/null
+++ b/srs
@@ -0,0 +1,15 @@
+#!/usr/bin/perl -w
+use strict;
+use warnings;
+ 
+use FindBin;
+use lib $FindBin::Bin;
+use Spline::Socketmap;
+use Spline::Srs;
+ 
+$Spline::Socketmap::timeout = 10;
+
+$Spline::Socketmap::handler = sub {
+    Spline::Srs->handle(@_);
+};
+Spline::Socketmap->run();
diff --git a/t/srs.t b/t/srs.t
new file mode 100644
index 0000000..824d8e9
--- /dev/null
+++ b/t/srs.t
@@ -0,0 +1,32 @@
+use strict;
+use warnings;
+
+use Test::More;# tests => 8;
+
+BEGIN {
+    use_ok 'Spline::Srs', qw(
+        check_exclude
+        srs_forward
+        srs_reverse
+    ) or BAIL_OUT;
+}
+
+# Testing ignores
+is(check_exclude('test@example.com', 'example.com'), 1, 'Ignore matching domain');
+is(check_exclude('test@example.de', 'example.com'), 0, 'Do not ignore non-matching domain');
+is(check_exclude('test@test.example.com', 'example.com'), 0, 'Do not ignore sub-domain');
+is(check_exclude('test@test.example.com', '.example.com'), 1, 'Ignore sub-domain if requested');
+
+# SRS Forward
+my $result = srs_forward('alex@example.com');
+isnt($result, undef, 'Not undef');
+like($result, qr/^SRS0[+=-]/, 'SRS0 Prefix');
+like($result, qr/\@spline\.inf\.fu-berlin\.de$/, 'Rewrite to spline-Domain');
+
+# SRS Reverse
+is(Spline::Srs::srs_forward('alex@domain.invalid'), 'SRS0=7tXNg=SJ=domain.invalid=alex@spline.inf.fu-berlin.de', 'Forward');
+is(Spline::Srs::srs_reverse('SRS0=7tXNg=SJ=domain.invalid=alex@spline.inf.fu-berlin.de'), 'alex@domain.invalid', 'Reverse');
+
+done_testing;
+
+# vim: set et ts=4: