Tociyuki::Diary RSSフィード

tociyuki による Perl・Ruby・C++・C で書き散らしたコードを中心に、日常雑記も混在 : B  F  twitter  GitHub  CPAN  本館  公開鍵
 

2017年05月26日

[]テキスト差分 Wu によるO(NP) 法の Hirschberg 法化まとめ

テキスト差分アルゴリズムでは現在知られている最も高速な Wu による O(NP) 法に、 2 N の作業領域で求める Hirschberg 法を摘要した試みへのリンクをまとめます。 第一期は Ruby によるスタディで、 第二期は、 diff に準拠したコマンドを C++11 で書いたものです。 組み合わせを網羅する力任せのテストで動作確認は済んでいますが、 あらゆる場合に正しく動作するかどうかはアルゴリズムとして証明する必要がありますが、 未だにできていません。

Ruby スタディ版

Hirschberg法 - Wu による O(NP) テキスト差分の試行 その1

Hirschberg法 - Wu による O(NP) テキスト差分の試行 その 2

C++11 実装版

GitHub - tociyuki/udiff-cxx11: word based unified color differences between two texts

Hirschberg-Wu 法による diff プログラム

Hirschberg-Wu 法による diff プログラム改良版

Hirschberg-Wu 法による GNU wdiff もどきプログラム

UCD Script ごとに分離する GNU wdiff もどきプログラム

Hirschberg-Wu 法による単語 diff 形式交じり unified 形式

diff もどきの unified 形式出力を mark ベクタなしで

[]マルチ・フェーズ認証 Plack::Middleware

Google の 2 フェーズ・ログインのように、 2 つ以上のログイン方式を組み合わせて認証を Plack::Middleware::Session を使っておこなう Middleware を試作しました。

tociyuki/libplack-middleware-auth-loginchain-perl

認証は、 最初の認証ページを GET して、 そこへ正しいパスワードを POST し、 リダイレクト先の次の認証ページを GET して、 そこへ正しいパスワードを POST してと順を追わない限り失敗するように作ってあります。 認証の途中で、 トップページ等へ移ってから、 再開しようとしても失敗します。 失敗時は、 最初の認証ページへリダイレクトするようにしています。 すべての認証を登録している順番に成功していき、 最後の認証に成功したら、 ユーザ・アカウントに紐付けてあるページへリダイレクトします。

この Middleware では、 認証中のログイン・セッション中に、 もう一度認証を確認することもできます。 その場合でも、 正しい順で GET と POST をおこなわないと認証に失敗します。 ただし、 ログイン・セッション中に、 認証の途中でトップページ等へ移るときは、 ログイン・セッションを維持します。 その場合でも、 途中で抜けた場所から認証を再開しようとしても、 先頭の認証ページへリダイレクトするのは同じです。

example に、 RFC 6238 時刻ベース・使い捨てパスワードと、 通常の平文パスワードの 2 段階認証だけをおこなう単純な PSGI アプリケーションを置いてあります。 この Middleware は、 認証ロジックとログイン・ページの作成をいっさいおこなわず、 Middleware を使う側で用意しておく流儀にしてあります。 builder の enable 時に、 それらを指定します。

use Plack::Builder;
use MyCrypt;

sub auth_totp {
    my($account, $password, $env) = @_;
    exists $users->{$account}{'totpkey'} or return;
    my $key = $users->{$account}{'totpkey'};
    $password eq MyCrypt->totp_sha1_6(time, $key) or return;
    return {'account' => $account, 'redirect_uri' => "/$account"};
}

sub auth_xcrypt {
    my($account, $password, $env) = @_;
    exists $users->{$account}{'password'} or return;
    my $saltyhash = $users->{$account}{'password'};
    $saltyhash eq MyCrypt->xcrypt($password, $saltyhash) or return;
    return {'account' => $account, 'redirect_uri' => "/$account"};
}

# Plack::Response を返すこと
sub auth_responder {
    my($req, $param) = @_;
    return render($req, 200, 'login.html', $param);
}

builder {
    enable 'Session';
    enable 'Auth::LoginChain',
        login_spec => [
            {'uri' => '/login',
             'authenticator' => \&auth_totp,
             'responder' => \&auth_responder,
             'realm' => 'One-Time Password'},
            {'uri' => '/login2',
             'authenticator' => \&auth_xcrypt,
             'responder' => \&auth_responder,
             'realm' => 'Password'},
        ],
        logout_spec => {
            'uri' => '/logout',
            'redirect_uri' => '/'
        };
    $app;
};

2017年05月22日

[]RFC 6238 TOTP 使い捨てパスワード

google-authenticator の時刻ベースだけに対応する、 二段階認証の使い捨てパスワード生成コマンドを描いてみました。 コマンドラインで動きます。

Time-Based One-Time Password generator command

使うには google-authenticator の Key-URI 形式をキー・ファイルへ格納しておき、 コマンドラインにそのファイル名を指定して実行します。 使い捨てパスワードを行先頭に表示し、 有効期間を示すためにアスタリスクを 1 秒ごとに減らして上書き表示します。 使い捨てパスワードは、 実行例の 483668 の部分で 30 秒間有効です。 30 秒の期限を過ぎたら、 新しい使い捨てパスワードを作って、 再表示します。

$ cat totpkey
otpauth://totp/Example:alice@example.net?secret=PBHWM6TSGJMEGZRU&issuer=Example
$ perl totpauth.pl totpkey
Example:alice@example.net
483668  |   ***************************|

使い捨てパスワードの計算は、 RFC 6238 の通りです。 引数は 5 つです。 UNIX タイムとキーに加えて、 3 つのパラメータを指定します。 Perl が 32 ビットでビルトしてあっても動作するように浮動小数点数を使って計算をおこなっています。

use POSIX ();
use Digest::SHA qw(hmac_sha1_hex hmac_sha256_hex hmac_sha512_hex);

my %HASH_FUNC = (
    'sha1'   => \&hmac_sha1_hex,
    'sha256' => \&hmac_sha256_hex,
    'sha512' => \&hmac_sha512_hex,
);

# RFC 6238 TOTP: Time-Based One-Time Password Algorithm
sub totp {
    my($unix_time, $key, $algorithm, $digits, $period) = @_;
    $algorithm ||= 'sha1';
    $algorithm = ($algorithm eq 'sha256') || ($algorithm eq 'sha512') ? $algorithm : 'sha1';
    $digits ||= 6;
    $digits = $digits == 6 ? 6 : 8;
    $period ||= 30;

    my $t = POSIX::floor($unix_time / $period);
    my $message = pack "NN", int($t / 4294967296.0), int($t % 4294967296.0);
    my $hash = $HASH_FUNC{$algorithm}->($message, $key);
    my $off = hex substr $hash, -1;
    my $bin0 = (hex substr $hash, $off * 2, 1) & 7;
    my $bin = $bin0 . (substr $hash, $off * 2 + 1, 7);
    my $mask = $digits == 6 ? 1000000 : 100000000;
    return sprintf "%0${digits}d", (hex $bin) % $mask;
}

表示部分は、 アカウントを表示した後、 使い捨てパスワードを計算しては、 行を上書きして書き直すようにしています。

use IO::Handle;

if ($issure_path || $param->{'issure'}) {
    print q(), $param->{'issure'} || $issure_path, ":";
}
print $account, "\n";
STDOUT->autoflush(1);
while (1) {
    my $time = time;
    my $otp = totp($time, $key, $algorithm, $digits, $period);
    print "\r$otp  |";
    my $sec = $time % $period;
    print " " x $sec, "*" x ($period - $sec), "|";
    sleep 1;
}

2017年05月08日

[]QuickTime Cubic VR mov から 6 枚の JPEG 画像をとりだす

以前作った Cubic VR ファイルの元であった 6 枚の画像を捨ててしまっていたものがあったので、 mov ファイルから画像を取り出すスクリプトを作りました。 QuickTime の定義部分を読み出すスクリプトを Perl で 10 年以上前に書いたものがあったので、 それを流用しています。

extract six faces from a QuickTime Cubic VR mov file

QuickTime のファイルは複数のトラックをファイルにまとめてあり、 Cubic VR の場合は、 トラック 1 が qtvr、 トラック 2 が pano に割り当ててあります。 この 2 つのトラックは画像を持たない、 パノラマのふるまいデータをトラックにしたものです。 画像はトラック pano が参照しているサンプリング・トラックに入っています。 このトラックの定義データに 6 枚の画像へのオフセットとサイズが記入してあるので、 それを使って画像を取り出します。 なお、 厳密にはトラック 2 の本体ふるまいデータを読み出して、 それの panoType メンバが cube になっていることをチェックするべきかもしれません。 ですが、 6 枚の画像になっているのは Cubic VR のはずなので、 枚数をチェックするだけにしています。

sub fetch_stbl {
    my($moov) = @_;
    my $trak = $moov->{'moov'}{'trak'};
    my $face = $trak->{'2'}{'tref'}[0]{'ref'}[0];
    my $nstco = @{$trak->{$face}{'mdia'}{'minf'}{'stbl'}{'stco'}};
    my $nstsz = @{$trak->{$face}{'mdia'}{'minf'}{'stbl'}{'stsz'}};
    $nstco == 6 or croak "not a cubic qtvr";
    $nstsz == 6 or croak "not a cubic qtvr";

    return $trak->{$face}{'mdia'}{'minf'}{'stbl'};
}

JPEG 画像の本体であるバイナリ列は、 オフセットへシークしてサイズ分読み出せば手に入ります。 それらに連番をふってファイルへ書き出します。

sub extract_jpeg {
    my($fd, $stbl, $basename) = @_;
    -e $basename or mkdir $basename;
    my $blob;
    for my $i (0 .. 5) {
        my $offset = $stbl->{'stco'}[$i];
        my $size = $stbl->{'stsz'}[$i];
        seek $fd, $offset, 0;
        $size == (read $fd, $blob, $size) or croak "read error";

        open my $jpg, '>', "$basename/$i.jpg" or croak "open: $!";
        binmode $jpg, ':raw';
        print $jpg $blob;
        close $jpg;
    }
}

QuickTime のトラック定義は mov ファイルの先頭から atom と呼ばれる入れ子のバイナリ列になっています。 それらをひたすら読んでいきます。 画像や音声本体ではなく定義データは moov の名称の atom の中に入っているので、 そこをハッシュ・リファレンスの $moov へ読み出します。 atom は先頭 4 バイトがビッグ・エンディアンのサイズで、 次の 4 バイトが atom の名称になっています。 サイズは先頭のサイズと名称も含んでおり、 既に読んだ 8 バイトを除いて、 get_atom へ渡します。

sub get_moov {
    my($fd, $moov) = @_;
    while (! eof($fd)) {
        my($len, $type) = unpack 'Na4', get_bytes($fd, 8);
        last if $len <= 0;
        if ($type eq 'moov') {
            get_atom($fd, $moov, $len - 8, $type);
            last;
        }
        else {
            seek $fd, $len - 8, 1;
        }
    }
}

get_atom はハッシュ・リファレンスの入れ子を深くして、 コンテナのときは再帰呼び出しをします。 トラック atom に対してはトラック識別子のハッシュにする追加処理をおこないます。 基本 atom は、 pack でバイナリをメンバに分解してハッシュ・リファレンスや配列リファレンスを作るのですが、 記述が煩雑なので省略します。

sub get_atom {
    my($fd, $atom, $skip, $parent) = @_;
    my $node = {};
    if ($parent ne 'trak') {
        $node = $atom->{$parent} = {};
    }
    while ($skip > 0) {
        my($len, $type) = unpack 'Na4', get_bytes($fd, 8);
        last if $len <= 0;
        $skip -= $len;
        if (exists $QT_CONTAINER_ATOM{$type}) {
            get_atom($fd, $node, $len - 8, $type);
        }
        elsif (exists $QT_SIMPLE_ATOM{$type}) {
            $QT_SIMPLE_ATOM{$type}->($fd, $node, $len - 8);
        }
        else {
            seek $fd, $len - 8, 1;
        }
    }
    if ($parent eq 'trak') {
        my $id = $node->{'tkhd'}{'track_id'};
        if (! exists $atom->{'trak'}) {
            $atom->{'trak'} = {};
        }
        $atom->{'trak'}{$id} = $node;
    }
}