新年早々暇なのでPerlでSIP Proxyを作った

いやホント暇ですね。
暇すぎるから超久々にPerlのコード書いちゃいましたよ。
年末の大掃除でたまたまラクダ本が出てきてなんだか懐かしかったもんで、つい。

ところで、はてなダイアリーってソースコードに色づけする機能があるんですね。こりゃ便利だ。

というわけで以下ソースコード。あ、ろくに試験してないんでろくに動かない可能性大です。パッチください。

#!/usr/bin/perl -w

use strict;
use Socket;

our %LOCDAT = ();
our ($destip, $destport);
our ($myhost, $myport);
if($#ARGV < 1) {
    print "usage:\n\tproxy.pl host port\n";
    exit(1);
}
$myhost = $ARGV[0];
$myport = $ARGV[1];

socket(SOCKET, PF_INET, SOCK_DGRAM, 0) or die "socket: $!";
bind(SOCKET, pack_sockaddr_in($myport, inet_aton($myhost))) or die "bind: $!";
print "ok\n";
while(1){
    my($buf);
    my($addr) = recv(SOCKET, $buf, 0x10000, 0) or next;
    my($srcport, $host) = unpack_sockaddr_in($addr);
    my($srcip) = inet_ntoa($host);
    print "<<<<< recvfrom ".$srcip.":".$srcport." <<<<<\n$buf\n";
    my($body, $method, $requri, $stcode, $reason, @hdrs) = &parse($buf);
    if($method ne "") {
        @hdrs = &insert_received($srcip, @hdrs);
        &proc_request($body, $method, $requri, @hdrs);
    } else {
        &proc_response($body, $stcode, $reason, @hdrs);
    }
}

sub parse() {
    my($buf) = @_;
    my($body, $method, $requri, $stcode, $reason, @hdrs);
    $buf =~ m/(\r\n\r\n)|(\r\r)|(\n\n)/mo;
    $body = $'; $buf = $`;
    $buf =~ s/\r\n?/\n/mgo;
    $buf =~ s/\n[ \t]+/ /mgo;
    $buf =~ /([^ ]+) ([^ ]+) ([^\n]+)\n/mo;
    if($3 eq "SIP/2.0") {
        $method = $1; $requri = $2; $stcode = $reason = "";
    } else {
        $method = $requri = ""; $stcode = $2; $reason = $3;
    }
    my(@tmp) = split(/\n/, $'); 
    my($i);
    @hdrs = ();
    for($i=0; $i<@tmp; $i++) {
        $tmp[$i] =~ m/\s*:\s*/o;
        push(@hdrs, $`);
        push(@hdrs, $');
    }
    return $body, $method, $requri, $stcode, $reason, @hdrs;
}

sub parse_addr_spec() {
    my($buf) = @_;
    my($user, $host, $port);
    $buf =~ m/sip:(([^@]+)@)?([^;:]+)(:(\d+))?/;
    if($2) {
        $user = $2;
    } else {
        $user = "";
    }
    $host = $3;
    if($5) {
        $port = $5;
    } else {
        $port = 5060;
    }
    return $user, $host, $port;
}

sub parse_name_addr() {
    my($buf) = @_;
    if($buf =~ m/<([^>]+)>/o) {
        return $`, $1, $';
    }
    return "", $buf, "";
}

sub insert_received() {
    my($srcip, @hdrs) = @_;
    my($pos) = &search("via", "v", @hdrs);
    my(@ary) = split(/\s*,\s*/, $hdrs[$pos + 1]);
    $ary[0] .= ";received=".$srcip;
    $hdrs[$pos + 1] = join(", ", @ary);
    return @hdrs;
}

sub proc_register() {
    my($requri, @hdrs) = @_;
    my($to_user, $to_host, $to_port) = &search_addr_spec("to", "t", @hdrs);
    my($dsp, $contact, $prms) = &search_name_addr("contact", "m", @hdrs);
    $LOCDAT{$to_user} = $contact;
    @hdrs = &conv2resp(@hdrs);
    push(@hdrs, "Contact");
    push(@hdrs, $contact);
    &send_resp("", "200", "OK", @hdrs);
}

sub proc_request() {
    my($body, $method, $requri, @hdrs) = @_;
    my($user, $host, $port) = &parse_addr_spec($requri);
    if($host eq $myhost && $port eq $myport) {
        if($method eq "REGISTER") {
            return &proc_register($requri, @hdrs);
        } elsif($user ne "") {
            $requri = $LOCDAT{$user};
            if(!$requri) {
                if($method ne "ACK") {
                    @hdrs = &conv2resp(@hdrs);
                    &send_resp($body, "404", "Not Found", @hdrs);
                }
                return;
            }
        }
    }
    my($pos) = &search("via", "v", @hdrs);
    $hdrs[$pos + 1] = "SIP/2.0/UDP $myhost:$myport, ".$hdrs[$pos + 1];
    $pos = &search("max-forwards", "", @hdrs);
    if($pos == -1) {
        push(@hdrs, "Max-Forwards");
        push(@hdrs, "70");
    } else {
        if($hdrs[$pos + 1] eq "0") {
            if($method ne "ACK") {
                @hdrs = &conv2resp(@hdrs);
                &send_resp($body, "483", "Too Many Hops", @hdrs);
            }
            return;
        }
        $hdrs[$pos + 1] = $hdrs[$pos + 1] - 1;
    }
    ($user, $destip, $destport) = &parse_addr_spec($requri);
    &send_msg($body, $method, $requri, "", "", @hdrs);
}

sub proc_response() {
    my($body, $stcode, $reason, @hdrs) = @_;
    my($pos) = &search("via", "v", @hdrs);
    my(@ary) = split(/\s*,\s*/, $hdrs[$pos+1]);
    shift(@ary);
    if($#ary == -1) {
        splice(@hdrs, $pos, 2);
    } else {
        $hdrs[$pos + 1] = join(", ", @ary);
    }
    &send_resp($body, $stcode, $reason, @hdrs);
}

sub search() {
    my($name1, $name2, @hdrs) = @_;
    my($i);
    for($i=0; $i<@hdrs; $i+=2) {
        if(lc($hdrs[$i]) eq $name1 || lc($hdrs[$i]) eq $name2) {
            return $i;
        }
    }
    return -1;
}

sub search_name_addr() {
    my($name1, $name2, @hdrs) = @_;
    my($pos) = &search($name1, $name2, @hdrs);
    if($pos == -1) {
        return "", "", "";
    }
    my(@ary) = split(/\s*,\s*/, $hdrs[$pos + 1]);
    return &parse_name_addr($ary[0]);
}

sub search_addr_spec() {
    my($name1, $name2, @hdrs) = @_;
    my($dsp, $addr_spec, $prms) = &search_name_addr($name1, $name2, @hdrs);
    return &parse_addr_spec($addr_spec);
}

sub conv2resp() {
    my(@hdrs) = @_;
    my($i, @new_hdrs);
    for($i=0; $i<@hdrs; $i+=2) {
        my($name) = $hdrs[$i];
        my($value) = $hdrs[$i + 1];
        if(lc($name) eq "via" or lc($name) eq "v" or lc($name) eq "from" or
           lc($name) eq "f" or lc($name) eq "to" or lc($name) eq "t" or
           lc($name) eq "call-id" or lc($name) eq "i" or lc($name) eq "cseq") {
            push(@new_hdrs, $name);
            push(@new_hdrs, $value);
        }
    }
    return @new_hdrs;
}

sub send_resp() {
    my($body, $stcode, $reason, @hdrs) = @_;
    my($top_via) = &search("via", "v", @hdrs);
    my(@tmp) = split(/\s*,\s*/, $hdrs[$top_via + 1]);
    $tmp[0] =~ m/SIP\s*\/\s*2\.0\s*\/\s*UDP\s+/o;
    my($buf) = $';
    $buf =~ m/([^:;]+)(\s*:\s*(\d+))?/o;
    $destip = $1; $destport = $3; $buf = $';
    if($buf =~ m/;received=([^;]+)/o) {
        $destip = $1;
    }
    if($buf =~ m/;rport=([^;]+)/o) {
        $destport = $1;
    }
    &send_msg($body, "", "", $stcode, $reason, @hdrs);
}

sub send_msg() {
    my($body, $method, $requri, $stcode, $reason, @hdrs) = @_;
    my($buf, $i);
    if($destip eq $myhost and $destport eq $myport) {
        return;
    }
    if($method ne "") {
        $buf = $method." ".$requri." SIP/2.0\r\n";
    } else {
        $buf = "SIP/2.0 ".$stcode." ".$reason."\r\n";
    }
    for($i=0; $i<@hdrs; $i+=2) {
        $buf .= $hdrs[$i].": ".$hdrs[$i + 1]."\r\n";
    }
    $buf .= "\r\n".$body;
    my($addr) = pack_sockaddr_in($destport, inet_aton($destip));
    send(SOCKET, $buf, 0, $addr);
    print ">>>>> sendto $destip:$destport >>>>>\n$buf\n";
}