#!/usr/local/bin/perl -w

# $Id: resolver-1.pl,v 1.2 2003/10/04 15:23:24 68user Exp $

#-------------------------------------------------------------
package QR;

sub Query    { 0 }
sub Response { 1 }

my %qr_table = (0 => '質問',
                1 => '応答'
                );

sub getName {
    my ($code) = @_;
    defined $qr_table{$code} ? $qr_table{$code} : '??';
}

#-------------------------------------------------------------
package OPCODE;

sub StandardQuery       { 0 };
sub InverseQuery        { 1 };
sub ServerStatusRequest { 2 };

my %opcode_table = (0 => '標準照会',
                    1 => '逆照会',
                    2 => 'サーバステータス照会',
                    );

sub getName {
    my ($code) = @_;
    defined $opcode_table{$code} ? $opcode_table{$code} : '??';
}

#-------------------------------------------------------------
package AA;

my %aa_table = (0 => '権威のない回答',
                1 => '権威のある回答',
                );

sub getName {
    my ($code) = @_;
    defined $aa_table{$code} ? $aa_table{$code} : '??';
}

#-------------------------------------------------------------
package TC;

sub NotTruncated { 0 }
sub Truncated    { 1 }

my %tc_table = (0 => '非分割',
                1 => '分割',
                );

sub getName {
    my ($code) = @_;
    defined $tc_table{$code} ? $tc_table{$code} : '??';
}

#-------------------------------------------------------------
package RD;

sub RecursionNotDesire { 0 }
sub RecursionDesire    { 1 }

my %rd_table = (0 => '非再帰要求',
                1 => '再帰要求',
                );

sub getName {
    my ($code) = @_;
    defined $rd_table{$code} ? $rd_table{$code} : '??';
}


#-------------------------------------------------------------
package RA;

my %ra_table = (0 => '再帰可能',
                1 => '再帰不可能',
);

sub getName {
    my ($code) = @_;
    defined $ra_table{$code} ? $ra_table{$code} : '??';
}

#-------------------------------------------------------------
package RCODE;

my %rcode_table = (0 => 'エラーなし',
                   1 => 'フォーマットエラー',
                   2 => 'サーバ側エラー',
                   3 => 'ネームエラー',
                   4 => '未実装',
                   5 => '拒否',
);

sub getName {
    my ($code) = @_;
    defined $rcode_table{$code} ? $rcode_table{$code} : "??";
}

#-------------------------------------------------------------
package TYPE;

sub A     { 1  }
sub NS    { 2  }
sub CNAME { 5  }
sub SOA   { 6  }
sub MB    { 7  }
sub MG    { 8  }
sub MR    { 9  }
sub NULL  { 10 }
sub WKS   { 11 }
sub PTR   { 12 }
sub HINFO { 13 }
sub MINFO { 14 }
sub MX    { 15 }
sub TXT   { 16 }
sub AAAA  { 28 }
sub ANY   { 255 }

my %type_table = (1   => 'A',
                  2   => 'NS',
                  5   => 'CNAME',
                  6   => 'SOA',
                  7   => 'MB',
                  8   => 'MG',
                  9   => 'MR',
                  10  => 'NULL',
                  11  => 'WKS',
                  12  => 'PTR',
                  13  => 'HINFO',
                  14  => 'MINFO',
                  15  => 'MX',
                  16  => 'TXT',
                  28  => 'AAAA',
                  255 => 'ANY',
                  );

my %type_code2name;
my %type_name2code;
foreach my $code (keys %type_table){
    my ($name) = $type_table{$code};
    $type_code2name{$code} = $name;
    $type_name2code{$name} = $code;
}

sub getName {
    my ($code) = @_;
    return $type_code2name{$code};
}

sub getCode {
    my ($name) = @_;
    $name =~ tr/a-z/A-Z/;
    return $type_name2code{$name};
}


#-------------------------------------------------------------
package CLASS;

sub Internet { 1 }
sub CSNET    { 2 }
sub CHAOS    { 3 }
sub Hesiod   { 4 }
sub Any      { 5 }

my %class_table = (1 => 'INTERNET',
                   2 => 'CSNET',
                   3 => 'CHAOS',
                   4 => 'HESIOD',
                   5 => 'ANY',
                   );

my %class_name2code;
foreach my $code (keys %class_table){
    my ($name) = $class_table{$code};
    $class_name2code{$name} = $code;
}

sub getName {
    my ($code) = @_;
    return $class_table{$code};
}

sub getCode {
    my ($name) = @_;
    $name =~ tr/a-z/A-Z/;
    return $class_name2code{$name};
}




#-------------------------------------------------------------
package main;

use strict;
use Socket;

if ( @ARGV < 2 || 4 < @ARGV ){
    print "お手製リゾルバ\n";
    print "書式: DNSサーバ名 名前解決ホスト名 [照会タイプ] [照会クラス]\n";
    print "    照会タイプ: A, NS, CNAME, MX, TXT, AAAA など。省略時は A。\n";
    print "    照会クラス: Internet, CHAOS など。省略時は Internet。\n";
    exit;
}

                # 接続先ホスト名を取得
my $dns_host = shift @ARGV;

                # 名前解決を行うホスト名を取得
my $query_host = shift @ARGV;

my $type_arg  = shift @ARGV || 'A';
my $class_arg = shift @ARGV || 'INTERNET';

my $type  = TYPE::getCode($type_arg);
if ( ! defined $type ){
    print "タイプ $type_arg は不正です。\n";
    exit 1;
}
my $class = CLASS::getCode($class_arg);
if ( ! defined $class ){
    print "クラス $class_arg は不正です。\n";
    exit 1;
}

                # 接続先ポート番号を取得
my $dns_port =  getservbyname('domain', 'udp') || 53;

                # ホスト名を、IP アドレスの構造体に変換
my $iaddr = inet_aton($dns_host)
        or die "$dns_host は存在しないホストです。\n";

                # ポート番号と IP アドレスを構造体に変換
my $sock_addr = pack_sockaddr_in($dns_port, $iaddr);

                # ソケット生成
socket(SOCKET, PF_INET, SOCK_DGRAM, 0)
        or die "ソケットを生成できません。$!";

my $query = make_query($type, $class);

if ( ! send(SOCKET, $query, 0, $sock_addr) ){
    die "send に失敗しました $!";
}

my $rcv_data;
recv(SOCKET, $rcv_data, 10000, 0) || die "$!";

parse_response($rcv_data);

exit 0;



#-------------------------------------------------------------
# DNS サーバに送る query を作成し、返す。

sub make_query {
    my ($type, $class) = @_;

    # 識別子設定
    my $id = pack('B16', '0000000000000000');

    # フラグを構成する各要素を設定
    my $qr     = QR::Query;             # 0:質問
    my $opcode = OPCODE::StandardQuery; # 0:標準照会
    my $aa     = 0;                     # Authoritative Answer (応答時にセット)
    my $tc     = TC::NotTruncated;      # 0:非分割
    my $rd     = RD::RecursionDesire;   # 1:再帰照会
    my $ra     = 0;                     # Recursion Available (応答時にセット)
    my $rcode  = 0;                     # Response Code (応答時にセット)

    # フラグ (0 と 1 の文字列)
    my $flg_binary = sprintf("%d%04d%d%d%d%d%03d%d",
                             $qr,
                             $opcode,
                             $aa,
                             $tc,
                             $rd,
                             $ra,
                             0,
                             $rcode);

    # フラグ (2バイトのバイナリ)
    my $flg = pack("B16", $flg_binary);

    # 質問数のみ 1。回答数、権威数、追加情報数はいずれも 0。
    my $question_count = pack('n', 1);
    my $response_count  = pack('n', 0);
    my $auth_count = pack('n', 0);
    my $ext_count = pack('n', 0);

    # foo.example.com というホスト名を 3foo7example3com という形に変換。
    my $query_name = &make_domain($query_host);

    # 照会タイプ・照会クラスを設定
    my $query_type  = pack('n', $type);
    my $query_class = pack('n', $class);

    # 質問は「照会名+照会タイプ+照会クラス」からなる。
    my $question = $query_name.$query_type.$query_class;

    # リクエストは「識別子+フラグ+質問数+回答数+権威数+追加情報数+質問」からなる。
    my $request = $id.$flg.$question_count.$response_count.$auth_count.$ext_count.$question;

    return $request;
}




#-------------------------------------------------------------
# DNS サーバから返されたデータを解析し、表示。

sub parse_response {
    my ($org_dgram) = @_;

    my $hr_line = "=========================================\n";

    # 識別子・フラグ・質問数・回答数・権威数・追加情報数を表示

    my ($id, $flg, $question_count, $response_count, $auth_count, $ext_count, $rest)
      = unpack('nnnnnna*', $org_dgram);

    # フラグを各ビットに分解
    my $qr     = ($flg >>15) & 0x01; # 最上位  1ビット目から 1ビット取得
    my $opcode = ($flg >>11) & 0x07; # 最上位  2ビット目から 3ビット取得
    my $aa     = ($flg >>10) & 0x01; # 最上位  5ビット目から 1ビット取得
    my $tc     = ($flg >> 9) & 0x01; # 最上位  6ビット目から 1ビット取得
    my $rd     = ($flg >> 8) & 0x01; # 最上位  7ビット目から 1ビット取得
    my $ra     = ($flg >> 7) & 0x01; # 最上位  8ビット目から 1ビット取得
    my $rcode  =  $flg       & 0x0f; # 最上位 12ビット目から 4ビット取得

    printf "識別子(Id): 0x%04lx\n", $id;
    printf "フラグ: 0x%04lx\n", $flg;
    printf "    QR (Query/Response): %s (%s)\n", $qr, QR::getName($qr);
    printf "    OPCODE: %s (%s)\n", $opcode, OPCODE::getName($opcode);
    printf "    AA (Authoritative Answer): %s (%s)\n", $aa, AA::getName($aa);
    printf "    TC (TrunCation): %s (%s)\n", $tc, TC::getName($tc);
    printf "    RD (Recursion Desired): %s (%s)\n", $rd, RD::getName($rd);
    printf "    RA (Recursion Available): %s (%s)\n", $ra, RA::getName($ra);
    printf "    RCODE (Response code): %s (%s)\n", $rcode, RCODE::getName($rcode);
    printf "質問数: $question_count\n";
    printf "回答数: $response_count\n";
    printf "権威数: $auth_count\n";
    printf "追加情報数: $ext_count\n";
    print $hr_line;

    # 質問の数だけ質問を解析し、表示

    foreach my $count ($question_count){
        my $domain;
        ($domain, $rest) = get_domain($rest, $org_dgram);
        my ($type, $class) = unpack('nn', $rest);
        substr($rest, 0, 4) = '';

        printf "質問: ドメイン名: %s\n", $domain;
        printf "質問: タイプ: %d (%s)\n", $type, TYPE::getName($type);
        printf "質問: クラス: %d (%s)\n", $class, CLASS::getName($class);
        print $hr_line;
    }

    my @rrs = (
               ['回答', $response_count],
               ['権威', $auth_count],
               ['追加情報', $ext_count],
              );

    foreach my $ref_array (@rrs){
        my ($desc, $count) = @$ref_array;

        foreach (1 .. $count){
            my $domain;

            ($domain, $rest) = get_domain($rest, $org_dgram);
            my ($type, $class, $ttl, $rdata_length) = unpack('nnNn', $rest);
            substr($rest, 0, 10) = '';

            printf "$desc($_): ドメイン名: %s\n", $domain;
            printf "$desc($_): タイプ: %d (%s)\n", $type, TYPE::getName($type);
            printf "$desc($_): クラス: %d (%s)\n", $class, CLASS::getName($class);
            printf "$desc($_): 生存時間(TTL): $ttl (秒)\n";
            printf "$desc($_): リソースデータ長: $rdata_length (バイト)\n";
        
            # リソースデータ取得
            my ($rdata) = substr($rest, 0, $rdata_length);
            substr($rest, 0, $rdata_length) = '';

            # タイプに応じてリソースデータの解析方法を変える

            my $rdata_for_print;

            if ( $type == TYPE::A ){
                # A レコード (IPv4 用 IP アドレス)
                $rdata_for_print = inet_ntoa($rdata);

            } elsif ( $type == TYPE::AAAA ){
                # AAAA レコード (IPv6 用 IP アドレス)
                my @couple_of_bytes = map { $_ = sprintf("%02lX", unpack('C', $_)) } split(//, $rdata);
                my @hexs;
                while (@couple_of_bytes>0){
                    push(@hexs, "$couple_of_bytes[0]$couple_of_bytes[1]");
                    shift @couple_of_bytes;
                    shift @couple_of_bytes;
                }
                $rdata_for_print = join(':', @hexs);
                $rdata_for_print =~ s/0000:/:/g;
                $rdata_for_print =~ s/:::+/::/g;
                $rdata_for_print =~ s/:0+([1-9A-F])/:$1/g;

            } elsif ( $type == TYPE::MX ){
                # MX レコード
                my ($preference, $mx) = unpack('na*', $rdata);
                my ($mx_domain) = get_domain($mx, $org_dgram);
                $rdata_for_print = "Preference: $preference  MX: $mx_domain";

            } elsif ( $type == TYPE::NS ){
                # 権威あるネームサーバ
                my ($ns_domain) = get_domain($rdata, $org_dgram);
                $rdata_for_print = $ns_domain;

            } elsif ( $type == TYPE::PTR ){
                # 逆引き
                my ($ptr_domain) = get_domain($rdata, $org_dgram);
                $rdata_for_print = $ptr_domain;

            } elsif ( $type == TYPE::CNAME ){
                # 別名
                my ($cname_domain) = get_domain($rdata, $org_dgram);
                $rdata_for_print = $cname_domain;

            } elsif ( $type == TYPE::TXT ){
                # テキスト
                $rdata_for_print = $rdata;

            } else {
                $rdata_for_print = 'このタイプのリソース解析は未実装です';
            }

            printf "$desc($_): リソースデータ: %s\n", $rdata_for_print;

            print $hr_line;
        }
    }
}



#-------------------------------------------------------------
# foo.example.com のようなホスト名を 3foo7example3com0 という
# 形に変換し、返す。

sub make_domain {
    my ($org_host) = @_;
    my $host = '';
    foreach ( split(/\./, $org_host) ){
        $host .= pack('C', length($_)) . $_;
    }
    $host .= pack('C', 0);
    return $host;
}



#-------------------------------------------------------------
# 3foo7example3com0 というようなデータを foo.example.com の
# ようなホスト名に変換し、返す。
#
# 引数 $data は 3foo7example3com0 というデータを指す。
# 引数 $org_data は DNS サーバから返された UDP データグラム全体。
# 
# 戻り値は 2つ。
#   1. 解析したホスト名
#   2. $data から先頭の 3foo7example3com0 を取り除いた残りの部分

sub get_domain {
    my ($data, $org_data) = @_;
    my @domains = ();

    while (1){
        my $len = unpack('C', $data);

        if ( ( $len & 0xc0 ) ==  0xc0 ){
            # 上位 2ビットが立っていたら、もう 1バイト読みこむ (合計 16ビット)。
            # そして上位 2ビットを落とし、残り 14ビットを DNS サーバから
            # 返された UDP データグラム先頭からのオフセットとして再帰する。

            my $offset = unpack('n', $data) ^ 0xc000;
            my $new_data = substr($org_data, $offset);
            substr($data, 0, 2) = '';

            my ($domain_part)  = get_domain($new_data, $org_data);
            push(@domains, $domain_part);
            last;

        } else {
            # 上位 2ビットが立っていないので、カウンタとして扱う。
            substr($data, 0, 1) = '';
        }

        if ( $len == 0 ){
            last;
        } else {
            push(@domains, unpack("a$len", $data));
            substr($data, 0, $len) = '';
        }
    }

    # この時点で @domains = ('foo', 'example', 'com') のようになっている。
    my $ret_domain = join('.', @domains);
    return ($ret_domain, $data);
}