読者です 読者をやめる 読者になる 読者になる

SECCON 2015 Final (Intercollege) 参加記

先週の土曜日にSECCONの決勝大会にnegainoidoというチームで参加してきました。
SECCON 2015 決勝大会 | SECCON 2015 NEWS

北千住駅から降りて東京電機大学に着くと受付にかっこいい可視化システムが置いてありました。優勝したチームdodododoは試合開始前から201ポイント稼いでいて格の違いを見せつけてきました。(本当は運営がテストのため得点を入れていただけです)
f:id:autotaker:20160202151856j:plain

決勝の形式について

学生大会の決勝は普段のJeopadyスタイルではなく、Attack&Defenceという形式でした。
決勝のシステムについて簡単に説明します。

  • 各チームに一台サーバが用意される。
  • 各サーバでは3つのWEBサービスを動かす。
    • vulnerable_blog: ブログ(というか掲示板?)PHPで書かれていた。
    • keiba: 競馬予想をするウェブサービス。nodejsで動かす。
    • sbox2015: ユーザがアップロードしたプログラムをサーバで実行する危険極まりないサービス。PythonCGIとして書かれていた。
  • 得点はAttackポイントとDefenceポイントに分かれる。
    • Attackポイント:他のチームのサーバからフラグを抜き出して運営サーバに送信することで攻撃されたチームの総得点の3%を奪うことができる。
    • Defenceポイント:運営が5分おきに各チームのWEBサービスの動作を確認するスクリプト(mechanize)を走らせる。それによってサービスが動いていることが確認できたら、一つのサービスあたり100ポイントもらえる。

試合経過

決勝開始と同時に各サーバへのアクセスが許可される。
ただし、各サーバのIPアドレスはエスパーしなければならない。
決勝に参加するようなウィザード級ハッカーにはその程度朝飯前なのだろう。
数分後、エスパー力の低いチームのためにIPアドレスが公開された。
とりあえず事前にもらったパスワードでサーバに接続しに行く。
ところでユーザ名は?
これはrootで良かったようだ。この程度ならなんとかエスパーできた。

このSSHなのだが、だいたい1分くらい放置すると接続を切られてしまう。
(試合が終わったあとに調べたら対処法はあったらしい。)
サーバの中をみるとvulnerable_blogとsbox2015は/var/www/以下で動いていることが確認できた。
keibaに関しては自分でnohup node app.js等で動かす必要があった。

ちなみに最初の15分は運営の動作確認スクリプトが走らないので、得点を得ることはできない。この間に、できる限り動作を把握することが肝要なのだろう。

開始15分が過ぎて、各チームの得点に変化が現れた。だいたいのチームがDefenceポイントを得点し始めた。Defenceポイントはとりあえず何もしなくてももらえるようだ。
さて、得点を伸ばすためにはAttackポイントをとりつつ、ほかのチームから得点を奪われないようにフラグを守る必要がある。ん?.... フラグ? .....

フラグって何だ????

特にサーバのソースコードやデータベース等に自分のフラグが置かれている様子はない。
意味がわからない。
そうこうしているうちにエスパー能力に優れた他のチームが攻撃を開始し出した。彼らにはフラグが何であるか理解できているのだろう。

しばらくしてチームメイトが他チームの攻撃を解析して、どうやらvulnerable_blogのDBの中にフラグが潜んでいるらしいことを突き止めてくれた。
データベースにはブログの利用者の投稿が残されている。それには投稿タイトル、内容、削除キーが含まれていた。
どうやらDefenceポイント確認のために運営が5分おきにブログに投稿を行うのだが、そのときの削除キーが自分のチームのフラグだったらしい。
そしてこれは試合後にわかったことだが、他のサービスでも運営の動作確認時に自分のチームのフラグが書き込まれるというゲームだったようだ。

試合中にはvulnerable_blog中のフラグのみしか気付けなかったので、他のチームからこれを奪うことにした。
奪うために利用したのはsbox2015に存在する自明な任意コード実行の脆弱性であった。
案外多くのチームのフラグをこの方法で奪うことができたようだ。
攻撃はTailedとcympfhに任せて、自分はvulnerable_blogの防衛を行うことにした。

vulnerable_blogでは次のような脆弱性を発見し修正した。

  • adminページの脆弱なパスワード
    • デフォルトではadminページにログインパスワードが"test"になっていたので推測されにくそうなものに変更した。adminページにログインすると各投稿の削除キーが閲覧できるのでフラグを盗まれるおそれがある。
  • SQLインジェクション
    • ブログを投稿する際のフォーム、及び投稿を閲覧する際のindex指定部等に脆弱性があったので適当にmysql-real-escape-stringで囲った。
  • XSS
    • ブログを表示する部分にXSS脆弱性があった。この脆弱性を用いれば、運営がフラグを書きこんだ際にjavascriptを用いてフラグを自サーバにリークさせることが可能だと考えられる。適切にhtmlspecialcharsで囲うことで修正した。

この全てを対策したあとではアクセスログを読む限りvulnerable_blogを使ってフラグを奪われることはなかったように思えた。しかしながら、他のチームはどんどん自分のチームのフラグを奪ってAttackポイントを稼いでいた。
試合中にはその原因はついにわからなかったが、おそらくsboxのフラグを盗まれていたのだろう。

結果

negainoidoの最終結果は11位でした。Attackポイントは上位チームに引けを取らない数字だったのに、防衛が全く足りていなかったのが敗因でした。
初見殺しが多かったもののゲーム自体は面白かったと思います。

大会後の懇親会で振る舞われたお寿司は美味しかったです。
来年からは学生枠で参加するのは難しいですが、Attack&Defenceの経験が積めたのでまた機会があればより善戦できるはずです。
f:id:autotaker:20160202152155j:plain

OCamlの末尾再帰について

この記事はMLアドベントカレンダー22日目の記事です。

プロローグ

autotakerはHaskellのList.sortが遅いので嘆いていた。
あまりに遅いので簡単なコードを書いて実験することにした。

gist082402e29104b2f21a6d

$ wc test300000.in
  300000  300000 2994897 test300000.in
$ head test300000.in
-145530267
165962464
79995549
-41622317
-133297703
38688159
191031379
-188084614
-187672271
-148432431
./ListSort < test300000.in > test300000.out
[2015-12-22 06:48:09.644106 UTC] begin
[2015-12-22 06:48:09.71299 UTC] parse done
[2015-12-22 06:48:10.610641 UTC] sort done
[2015-12-22 06:48:10.610854 UTC] Sorting: 0.897651s
[2015-12-22 06:48:10.707304 UTC] output done
[2015-12-22 06:48:10.707538 UTC] Elapsed Time: 1.063198s

30万個の整数列をソートするのに900msもかかるのだ。

比較のためにC++でもソートしてみた。

gist1b7a9a6f6b9c0f446ae5

$ g++-5 -std=c++11 -O3 sort.cpp -o sort
$ time ./sort < test300000.in > test300000.out
Sorting: 22ms

real	0m0.151s
user	0m0.133s
sys	0m0.010s

C++のstd::sortは爆速でわずか22msでソートが完了した。なんとHaskellのList.sortの40倍以上の速さである。これはいくらなんでも速すぎる。
調べたところstd::sortはIntro sortと呼ばれるQuick sortを少し賢くしたようなアルゴリズムで実装されている一方でList.sortはmerge sortに毛が生えたようなアルゴリズムで実装されているらしい。アルゴリズムが違うならまあ仕方ない。

ところで、標準ライブラリのソートにマージソートが採用されていてよくHaskellと比較される関数型言語があるではないか。
そうOCamlである。OCamlコンパイラGHCに比べてそれほどアグレッシブな最適化をするわけでもないし、さすがにOCamlよりは速いだろうと予想してコードを書いてみた。

OCamlのソートのバグ?

さて、ここまでが長い前振りで、ここから今回の本題に入ろう。
まず、次のようなOCamlのコードを書いて実験してみた。


gistebed443ea61424295eca

$ ocamlopt sort.ml -o sort-ml
$ time ./sort-ml < test300000.in > test300000.out
Sorting: 0.14416s

real	0m0.874s
user	0m0.393s
sys	0m0.470s

全体の実行時間が遅いのは主に入出力のせいなので気にしないこととして、
OCamlのList.sortは144msであり、Haskellの6倍以上速い。
これは意外な結果だったが、念のため出力があっているかを確認したときに興味深いことがわかった。

$ diff test300000.ans test300000.out | head
2,3d1
< -214745540
< -214744494
14d11
< -214729150
18d14
< -214725140
21d16
< -214723392
37d31

なんと正しくソートできていないではないか!
この短く単純なコードのどこに私はバグを仕込んでしまったのだろう。

まずは入力を正しく読めているか確認した。

let main _ = 
    let ps = read_ints [] in
    let start_t = Sys.time() in
    Printf.fprintf stderr "length: %d\n" (List.length ps);
    let qs = List.sort compare ps in
    let end_t = Sys.time() in
    Printf.fprintf stderr "Sorting: %.5fs\n" (end_t -. start_t);
    output_ints qs;;
./sort-ml < test300000.in > test300000.out
length: 261056
Sorting: 0.14787s

どうやらバグはread_intsにあるらしい。

let rec read_ints acc =
    try
        let v = read_int() in
        read_ints (v::acc)
    with
        _ -> List.rev acc

このコードを書いた時の私の気持ちはこうだ。

  1. 入力はデカイので末尾再帰にする必要がある。アキュムレータ引数を用意しよう。
  2. read_intのドキュメントにはファイルの末尾に達したら、End_of_file例外が投げられるとかいてある。tryで包んで例外を捉えよう。
  3. 例外の名前打ち込むの面倒だし、使い捨てのコードだから_でマッチさせてもいいよね!

3つ目が私の怠慢であることは認めるが、上の二つは正しそうに思えないだろうか。

私は自身の怠慢を認め、期待する例外の名前を正しく書くことにした。

let rec read_ints acc =
    try
        let v = read_int() in
        read_ints (v::acc)
    with
        End_of_file -> List.rev acc
$ ocamlopt sort.ml -o sort-ml
$ ./sort-ml < test300000.in > test300000.out
Fatal error: exception Stack_overflow

!!!!!Fatal error: exception Stack_overflow!!!!!
読者の中にはもう気づいた人もいるだろうが、実はこのread_intsは末尾再帰になっていないのだ。
なぜかというと、read_intsにはread_ints(v::acc)を呼び出したあとに例外処理のコードがあるので、例外をキャッチした時にどのハンドラに渡すかを保存するためにスタックが必要になるためだ。

正しく末尾再帰にするためには例外をoption型に変換してやらないといけない。

let rec read_ints acc =
    let r = try Some (read_int()) with 
        End_of_file -> None in
    match r with
        Some(v) -> read_ints (v::acc)
        | None -> List.rev acc

このコードは多少不恰好だが、定数サイズのスタックしか消費しない。

gist764a6d75741e2f807bc5

$ ocamlopt sort1.ml -o sort1-ml
$ time ./sort1-ml < test300000.in > test300000.out
length: 300000
Sorting: 0.18463s

real	0m0.972s
user	0m0.436s
sys	0m0.530s
$ diff test300000.out test300000.ans

こうしてバグは修正された。めでたしめでたし。

後日談というか、今回のオチ

こうしてOCamlコードのバグは直ったわけだが、実験の結果、OCamlのList.sortは184msであり、やはりHaskellのList.sortがクソ遅いのはアルゴリズムのせいではなく、実装が悪いのだと考えられる。
競技Haskellerとしてこんな状況は許されないのでメモリ効率が悪いListの代わりにVectorを使ってマージソートを実装した。
gistdb303c4aae8e1ce9776b

$ ghc -O2 VecSort.hs
[1 of 1] Compiling Main             ( VecSort.hs, VecSort.o )
Linking VecSort ...
$ ./VecSort < test300000.in > test300000.out
[2015-12-22 07:58:53.725504 UTC] begin
[2015-12-22 07:58:53.805494 UTC] parse done
[2015-12-22 07:58:54.00343 UTC] sort done
[2015-12-22 07:58:54.003704 UTC] Sorting: 0.197936s
[2015-12-22 07:58:54.092547 UTC] output done
[2015-12-22 07:58:54.092758 UTC] Elapsed Time: 0.367043s

このように198msと、OCamlと大差ない時間になった。

SECCON 2015 Qual Writeup Crypto 200 Find the prime numbers

問題

つなぐと

2622440554406490912 + 0147433867683690946 = 4258610457570922687

などと表示される。数字は3秒おきに更新される。

解法

もらったソースを読む。

	while 1:
		x = pow(random.randint(1000000000, 9999999999), n, (n * n))
		o = (pow(n + 1, 1, n * n) * x) % (n * n)
		y = (((pow(o, l, n * n) - 1) // n) * d) % n
		if y == 1:
			break
	c = (pow(n + 1, int(v["num"]), n * n) * x) % (n * n)
	h = (c * o) % (n * n)
	q = "%019d + %019d = %019d" % (c, o, h)
	print q
	
	z = "QUERY_STRING"
	if z in os.environ and os.environ[z] != "":
		if w[e]["time"] < t and os.environ[z] == v["num"]:
			print "SECCON{" + v["flag"] + "}"
		w[e]["time"] = t + 60
		w[e]["outp"] = q
	else:
		w[e]["time"] = t + 3
		w[e]["outp"] = q

何をやっているのかはよくわからないが、v["num"]を当てれば良いらしい。
まず、nを当てたい。表示しているのはよく読むと

 x (n + 1)^k + (n + 1) x = (n + 1)^{m+1} x^2 \mod n^2
という等式のようだ。どう考えても、左辺+記号は*の間違いだろう。
つまり
 a * b = c \mod n^2
となる、 a, b, cがあたえられるわけだ。
ここから
 a * b = c + l n^2
 l n^2 = a * b - c
つまり、 a* b - c素因数分解すれば n^2の約数(素数p,q)が得られる。
たかだか36桁程度なのでmsieveを使って解ける(べつにためし割りでも大丈夫だろう)

$ msieve -v 386636553706711704268844486594760065
factoring 386636553706711704268844486594760065 (36 digits)
p1 factor: 5
p1 factor: 7
p2 factor: 11
p5 factor: 42727
p5 factor: 42727
p5 factor: 58757
p5 factor: 58757
prp15 factor: 159337556575289

よって、 n = 42727 \times 58757 = 2510510339が得られた。
次に、
 x (n + 1)^k + (n + 1) x = (n + 1)^{m+1} x^2 \mod n^2
 xを復元したい。これも簡単で、 x = b(n + 1)^{-1} \mod n^2と求められる。
最後に
 x (n + 1)^k = a から k = \log_{n+1}(a x^{-1}) と求められる。
離散対数はPARI/GPを用いた。

? znlog(3792102298388437469,Mod(2510510340, 6302662162225894921))
%1 = 1510490612

 k = 1510490612が求まったのでサーバに送れば良い。
FLAG: SECCON{SECCoooo_oooOooo_ooooooooN}

たぶん、想定解ではないが、いずれにせよ桁が小さすぎるのでどうやっても解けるとおもう。

使ったPythonスクリプト

giste65da419e982225b22de

SECCON 2015 Qualに参加しました。

チームnegainoidoで参加しました。

チームメンバーはautotaker, atetubou, cympfh, garasubo, isurugieri, tailedだった。
atetubouとtailedは台湾旅行(ICPCのアジア地区予選)中だったので遠隔参加でした。

コンテスト開始時

開始直後にatetubouがStart SECCON CTFを通した。

2015-12-05 15:02:16: negainoido: 50 (+50), Start SECCON CTF

SECCON Warsはやることははっきりしていたのでgarasuboに取り組んでもらった。

16時

2015-12-05 15:58:23: negainoido: 150 (+100), Reverse-Engineering Android APK 1

by autotaker

2015-12-05 16:03:40: negainoido: 250 (+100), Command-Line Quiz

by atetubou

2015-12-05 16:21:37: negainoido: 350 (+100), SECCON WARS 2015

by garasubo

コンテストサーバがおもくなりフラグを送信できなかったり、問題が見られなかったりでイライラしていた。

17時

2015-12-05 17:03:16: negainoido: 450 (+100), Connect the server

by tailed, autotaker

2015-12-05 17:45:33: negainoido: 750 (+300), Decrypt it

by atetubou

台湾でICPCの準備中とは思えないatetubouとtailedの仕事の早さに驚かされた。
本戦に行けることになったときに、チーム内で選抜をするという脅しをかけたのが良かったのかもしれない。
atetubouにunzipが既知平文攻撃ではないかと教えてもらい、cympfhが手元でpkcrackを走らせ始めた。

Entry formについてtailed, autotaker, cympfhでいろいろと試す。

18時

2015-12-05 18:39:55: negainoido: 850 (+100), Entry form

by tailed, cympfh, autotaker
Entry formの問題でtailedがブラインドOSインジェクションで/SECRETS/以下を読む。
atetubouとtailedが移動でafkしている間にbackdoor123.phpを発見して解いた。

garasuboが帰宅。

19時

isurugieriがCodeThanksFestivalから帰ってきて参加。
晩御飯を食べる。

20時

2015-12-05 20:00:45: negainoido: 950 (+100), Unzip the file

by cympfh
pkcrackがようやく解読してくれた。長い戦いだった。
atetubou, tailedがホテルに移動し、スカイプ通話ができるようになった。
実装の面倒なQRを分担して片付けることになった。
isurugieriとcympfhがQR(Windows)、実装に定評のあるatetubouがQR(Nonogram)を担当。

22時

2015-12-05 22:00:29: negainoido: 1150 (+200), Find the prime numbers

by autotaker, tailed

2015-12-05 22:06:51: negainoido: 1450 (+300), Exec dmesg

by tailed

2015-12-05 22:45:55: negainoido: 1750 (+300), QR puzzle (Nonogram)

by atetubou
Find the prime numbersは何をしているのかはよくわからなかったが、解くだけなら簡単な素因数分解と離散対数を解くだけだった。なんだったんだろう。

23時

2015-12-05 23:36:37: negainoido: 1850 (+100), Steganography 3

by atetubou, tailed
OCRでバイナリを読んで実行した。floodfillの意味をtailedがエスパーしてくれた。
QR(Windows)のデバッグが楽しそうだった。

24時

2015-12-06 00:25:10: negainoido: 2050 (+200), QR puzzle (Windows)

by cympfh, isurugieri, autotaker

2015-12-06 00:48:04: negainoido: 2150 (+100), Steganography 1

by autotaker

このあと、tailedが途中まで書いてくれたQR(Web)のデバッグをcympfhとautotakerでやった。
バグはなおったが、strong-qr-decoderがうまく動かないため、とりあえず諦めた。

深夜

みんな自宅に帰った。TreeWalkerは解法が見えてしまったので、睡魔と闘いながらautotakerが解析した。

2015-12-06 06:18:30: negainoido: 2350 (+200), FSB: TreeWalker

by autotaker
明らかに時間かけすぎだった。寝るべきだった。

翌朝8時

2015-12-06 08:45:12: negainoido: 2400 (+50), Last Challenge (Thank you for playing)

by atetubou?

2015-12-06 08:47:28: negainoido: 2800 (+400), QR puzzle (Web)

by tailed
台湾勢が残しておいた問題を朝飯前に片付けてくれた。ありがたい。
atetubouとtailedはICPCのコンテストに出かけた。

午前中

2015-12-06 10:24:50: negainoido: 3000 (+200), Fragment2

by autotaker

2015-12-06 11:09:12: negainoido: 3100 (+100), 4042

by autotaker, garasubo, isurugieri, tailed
少し寝たら神託が降りてきてあっさり解けた。神に感謝したい。

コンテスト終了まで

この時点で方針の立っている問題がなくなってしまったので、autotaker, cympfh, garasuboの3人でHardware1を解きに行くことにした。LEDの配置さえわかればなんとかなるかと思っていたが、大量のトランジスタがあることに気づき、自分たちの無力を悟った。

結果

3100pts 26位だった。
f:id:autotaker:20151206172710p:plain
去年は3人で2000点くらいだったのでまあまあよくできたと思う。
日本人チームで9位なので学生枠で決勝に行けそう?

またatetubouとtailed(とflowlight氏)が参加していたICPCの方もなかなか良い結果だったようだ。

Template HaskellでJSONデコーダの導出

概要

最近、CodeRunnerというAIコンテストの予選BでJSONデータをいじる必要が出てきたのでHaskellJSONを読めるようにAesonを触ってみた。さらにTemplateHaskellを用いてレコード型の定義からJSONデコーダを自動導出できるようにしてみた。

背景

予選Bの問題は以下のリンクから閲覧できる。coderunner.jp

問題自体も面白いが、今回興味があるのはAPIで渡されるJSONデータである。
そのJSONは以下のような仕様になっている。

  • power: 現在の攻撃力
  • damage: 今までに与えた合計ダメージ
  • hp: 一番前の敵の体力
  • maxhp: 一番前の敵の初期体力
  • hps: 後ろにいる敵の体力の配列(戦う順に並んでいて最後に戦う敵が一番最後になる)
  • friend: 同じ部屋にいる自分以外のユーザーの配列(id昇順)
    • id: ユーザーID
    • power: そのユーザーの現在の攻撃力
    • damage: そのユーザーの今までに与えた合計ダメージ
  • log: イベントの配列(イベントは情報取得APIを前回リクエストしてから今回リクエストした間に起きたもののみを差分として表示する)
    • id: 攻撃したユーザーのユーザーID
    • enemy: 攻撃された敵のID(一番前の敵を含む残り敵数に等しい)
    • time: ためた時間[ミリ秒表記]
    • hp: 攻撃される前の敵の体力

このような構造はHaskellのレコード型を用いて自然に書くことができる。フィールド名にアンダースコアをつけているのは後でLensを使いたいからだ。

module Info where
data GameInfo = GameInfo { _myPower   :: Int
                         , _myDamage  :: Int
                         , _curHp     :: Int
                         , _maxHp     :: Int
                         , _hps       :: [Int]
                         , _friends   :: [Friend]
                         , _logs      :: [Log] }
                         deriving Show

data Friend = Friend { _friendId     :: String
                     , _friendPower  :: Int
                     , _friendDamage :: Int }
                     deriving Show

data Log = Log { _userId  :: String
               , _enemyId :: Int
               , _time    :: Int
               , _hp      :: Int }
               deriving Show

ここで問題となるのがフィールド名の衝突である。
例えばAPIの仕様では"id"というフィールド名はfriendの配列の中とlogの配列の中の両方で使われている。Haskellでは同じフィールド名を異なるレコード型に用いるためには別のファイルに記述しなければならず面倒である。同じファイルに定義する場合にはプリフィックスをつけるなどして適当に名前を変更しなければならない。

JSONのパーズ

JSONデータのパーズにはAesonというライブラリを使う。
aeson: Fast JSON parsing and encoding | Hackage
ライブラリに

decode :: FromJSON a => ByteString -> Maybe a

という関数があるので、GameInfo, Friend, LogのそれぞれをFromJSONのインスタンスにしてやれば良い。

{-# LANGUAGE OverloadedStrings #-}
import Data.Aeson
import Data.Aeson.Types

instance FromJSON Log where
    parseJSON (Object v) =
        Log <$> v .: "id"
            <*> v .: "enemy"
            <*> v .: "time"
            <*> v .: "hp"
    parseJSON invalid = typeMismatch "Log" invalid

instance FromJSON Friend where
    parseJSON (Object v) =
        Friend <$> v .: "id"
               <*> v .: "power"
               <*> v .: "damage"
    parseJSON invalid = typeMismatch "Friend" invalid

instance FromJSON GameInfo where
    parseJSON (Object v) =
        GameInfo <$> v .: "power"
                 <*> v .: "damage"
                 <*> v .: "hp"
                 <*> v .: "maxhp"
                 <*> v .: "hps"
                 <*> v .: "friend"
                 <*> v .: "log"
    parseJSON invalid = typeMismatch "GameInfo" invalid

簡単だし、typeMismatchとかいう関数を呼べばエラーメッセージもいい感じに出してくれる。
実際にパーズするのはこんな感じでできる。

import qualified Data.ByteString.Lazy as B
import Data.Aeson(eitherDecode)
import Text.Printf

testAeson :: FilePath -> (GameInfo -> IO ()) -> IO ()
testAeson path cont = do
    putStrLn $ "Case: " ++ path
    s <- B.readFile path
    case eitherDecode s of
        Left err -> putStrLn err
        Right info -> cont info

main = testAeson "sample.json" print
$ cat sample.json
{"power":2604996,"damage":40599634,"hp":13879712,"maxhp":39050001,"hps":[10857025,17480761,27899524],"friend":[{"id":"PlayerB","power":1542564,"damage":72452052},{"id":"PlayerC","power":1522756,"damage":52232156}],"log":[{"id":"PlayerC","enemy":4,"time":5017,"hp":39050001},{"id":"PlayerB","enemy":5,"time":5017,"hp":25158831},{"id":"PlayerA","enemy":5,"time":4265,"hp":43349056}]}

$ cat sample-e.json
{"power":2604996,"damage":40599634,"hp":13879712,"maxhp":39050001,"hps":[10857],"friend":[],"log":[0]}

$ ghci InfoTest.hs
GHCi, version 7.10.2: http://www.haskell.org/ghc/  :? for help
[1 of 2] Compiling Info             ( Info.hs, interpreted )
[2 of 2] Compiling Main             ( InfoTest.hs, interpreted )
Ok, modules loaded: Info, Main.
*Main> testAeson "sample.json" print
Case: sample.json
GameInfo {_myPower = 2604996, _myDamage = 40599634, _curHp = 13879712, _maxHp = 39050001, _hps = [10857025,17480761,27899524], _friends = [Friend {_friendId = "PlayerB", _friendPower = 1542564, _friendDamage = 72452052},Friend {_friendId = "PlayerC", _friendPower = 1522756, _friendDamage = 52232156}], _logs = [Log {_userId = "PlayerC", _enemyId = 4, _time = 5017, _hp = 39050001},Log {_userId = "PlayerB", _enemyId = 5, _time = 5017, _hp = 25158831},Log {_userId = "PlayerA", _enemyId = 5, _time = 4265, _hp = 43349056}]}
*Main> testAeson "sample-e.json" print
Case: sample-e.json
Error in $.log[0]: failed to parse field log: expected Log, encountered Number

Template Haskellで自動導出

上のインスタンス宣言はレコード型のフィールド名とJSONオブジェクトのレコード名の対応関係さえ与えてやれば自動導出できそうなのでやってみた。
一応aesonのライブラリ自体にもGenericを用いた自動導出とTemplateHaskellを用いた自動導出があるのだが、それらはHaskellのデータ型をイイ感じのJSONにするのには向いていても、すでにあるJSON型をデコードするのにはあまり向いていないように見えた。

自動導出器はTemplate.hsに実装した。
使い方はこんな感じである。

{-# LANGUAGE TemplateHaskell #-}
module Info where
import Template

data Log = Log { _userId  :: String
               , _enemyId :: Int
               , _time    :: Int
               , _hp      :: Int }
               deriving Show

data Friend = Friend { _friendId     :: String
                     , _friendPower  :: Int
                     , _friendDamage :: Int }
                     deriving Show

data GameInfo = GameInfo { _myPower   :: Int
                         , _myDamage  :: Int
                         , _curHp     :: Int
                         , _maxHp     :: Int
                         , _hps       :: [Int]
                         , _friends   :: [Friend]
                         , _logs      :: [Log] }
                         deriving Show

mkFromJSON ''Log [ ('_userId,  "id")
                 , ('_enemyId, "enemy")
                 , ('_time,    "time")
                 , ('_hp,      "hp") ]

mkFromJSON ''Friend [ ('_friendId,     "id")
                    , ('_friendPower,  "power")
                    , ('_friendDamage, "damage") ]

mkFromJSON ''GameInfo [ ('_myPower,  "power")
                      , ('_myDamage, "damage")
                      , ('_curHp,    "hp")
                      , ('_maxHp,    "maxhp")
                      , ('_hps,      "hps")
                      , ('_friends,  "friend")
                      , ('_logs,     "log") ]

mkFromJSONというマクロがFromJSONのインスタンスを自動導出してくれる。第一引数には導出したい型の名前、第二引数にはフィールド名の対応関係を記したリストを渡せば良い。一応簡単なエラーハンドリングもしているのでフィールド名の漏れ等も検出して教えてくれるようになっている。

Template.hsの実装はこんな感じ。TemplateHaskell触ったのは初めてだったのでチュートリアル等を見ながらなんとなく実装した。QuasiQuote使いつつやればそんなに難しくもなかった。
これらのサイトが参考になった。
できる!Template Haskell (完) - はてな使ったら負けだと思っている deriving Haskell - haskell
Language.Haskell.TH.Syntax

{-# LANGUAGE TemplateHaskell #-}
module Template(mkFromJSON) where
import Language.Haskell.TH
import Data.Aeson
import Data.Aeson.Types
import qualified Data.Text as Text
import Control.Monad

validateInfo :: Name -> [(Name,String)] -> Q Name
validateInfo name fieldmap = do
    info <- reify name
    dec <- case info of
        TyConI dec -> return dec
        _ -> fail $ nameBase name ++ " must be a type constructor"
    cons <- case dec of
        DataD _ _ _ cons _ -> return cons
        _ -> fail $ nameBase name ++ " must be a data type"
    cnstr <- case cons of
        [cnstr] -> return cnstr
        _       -> fail $ nameBase name ++ " must have only one constructor"
    (cname,fields) <- case cnstr of
        RecC cname fields -> return (cname,map (\(x,_,_) -> x) fields)
        _ -> fail $ nameBase name ++ " must be a record type"
    mapM_ (\(field,_) -> unless (field `elem` fields) $
            fail $ "invalid field name" ++ nameBase field)
          fieldmap
    mapM_ (\field -> unless (field `elem` map fst fieldmap) $
            fail $ "corresponding JSON field of the field " ++ nameBase field ++ " is not found")
          fields
    return cname

mkFromJSON :: Name -> [(Name,String)] -> Q [Dec]
mkFromJSON name fieldmap = do
    cnstr <- validateInfo name fieldmap
    vars <- mapM (\y -> (,) y <$> newName "x") fieldmap
    v <- newName "v"
    let invalid = [| typeMismatch $(stringE $ nameBase name) $(varE v) |]
        -- body = do
        --    x1 <- v .: JSONfield1
        --    x2 <- v .: JSONfield2
        --    ...
        --    xn <- v .: JSONfieldn
        --    return $ $cnstr{ field1 = x1, ... fieldn = xn }
        body = doE (stmts ++ ret)
        stmts = [ bindS (varP tvar) [| $(varE v) .: Text.pack $(stringE jsonfield)|] 
                           | ((_,jsonfield),tvar) <- vars ]
        ret = [ noBindS (appE (varE 'return) (recConE cnstr fieldDefs)) ]
        fieldDefs = [ return (field, VarE tvar) | ((field,_),tvar) <- vars ]
    [d| instance FromJSON $(conT name) where
             parseJSON (Object $(varP v)) = $body
             parseJSON $(varP v)          = $invalid |]

終わりに

実装自体は出来たが、これでコードが短くなったかと言われれば微妙だ。
使う側にOverloadedStringsとかの拡張とかライブラリのインポートをしなくても良いのが便利かもしれない。

GADTを用いた型安全なCPS変換の実装

概要

CPS変換とはラムダ項と継続を入力として型Xを持つラムダ項を出力するプログラム変換である。
HaskellのGADTという機能を使うと型Tを持つラムダ項を表すデータ型Term Tを定義できる。
CPS変換が正しいことは
cps :: Term T -> Term ([T] -> X) -> Term Xという型がつくことで表現される。
(ここで[T]は型TをCPS変換した型)

GADTは表現力の高いDSLであるが、parse :: String -> Maybe (Term T)のような関数を書くことはできないため、標準入力からラムダ項を受け取りcps関数に渡すためには少し工夫がいる。

今回はtypeCheck :: Term' -> A -> (forall T. Term T -> A) -> A
という関数を実装することでこの問題を解決した。

実装は以下で公開されている。github.com

とてもとても簡単な解説

CPS変換の実装はSyntax.hsで、パーズした入力をGADTのラムダ項を生成する部分は
TypeCheck.hsにある。詳細は実装を読んでほしい。後日解説を書くかもしれない。

実行例はこんな感じ

$ ./cpstransformer
\(x::o) -> x
Parsed: \(x :: o) -> x
TypeCheck : OK
CPS : (\(x :: o -> (o -> o) -> o) -> end) (\(x :: o) -> \(k :: o -> o) -> k x) 
\(a :: o) -> (\(x :: o -> o) -> x a) (\(b :: o) -> b)
Parsed: \(a :: o) -> (\(x :: o -> o) -> x a) (\(b :: o) -> b)
TypeCheck : OK
CPS : (\(x :: o -> (o -> o) -> o) -> end) (\(a :: o) -> \(k :: o -> o) -> (\(f :: (o -> (o -> o) -> o) -> (o -> o) -> o) -> (\(x :: o -> (o -> o) -> o) -> f x k) (\(b :: o) -> \(k :: o -> o) -> k b)) (\(x :: o -> (o -> o) -> o) -> \(k :: o -> o) -> (\(f :: o -> (o -> o) -> o) -> (\(x :: o) -> f x k) a) x))
\(x :: o -> o) -> x x
Parsed: \(x :: o -> o) -> x x
TypeCheck : failed

参考文献

今回実装したCPS変換は次のサイトを参考にしている。
How to compile with continuations

構文木にIdを振りたい。

構文木に情報を追加したいときにFix使うとちょっと楽だよっていう話。
例えば

data Term = Var String | Lam String Term | App Term Term

みたいなデータの各ノードにIdを振りたいとする。
ナイーブにやると

data ITerm = IVar Int String | ILam Int String ITerm | IApp Int ITerm ITerm

こんな感じになるだろうか。
コンストラクタの名前が変わって冗長だ。

これに対してFixを使うとこうなる。

newtype Fix f = In (f (Fix f))

data TermF a = Var String | Lam String a | App a a
newtype ITermF a = ITermF (Int, TermF a) 
newtype Term = Term (Fix TermF)
newtype ITerm = ITerm (Fix ITermF)

これなら他に型情報とかを追加したくなってもnewtypeで簡単に追加できる。
Idを振るサンプルは以下のとおり。

cata :: Functor f => (f a -> a) -> Fix f -> a
cata f (In t) = f (fmap (cata f) t)

incr :: State Int Int
incr = do
    i <- get
    put $! i + 1
    return i

assignId :: Term -> State Int ITerm
assignId (Term _t) = ITerm <$> cata f _t where
    f (Var s) = c $ pure $ Var s
    f (App t1 t2) = c $ App <$> t1 <*> t2
    f (Lam x t) = c $ Lam x <$> t
    c t = In . ITermF <$> ((,) <$> incr <*> t)

newtype同士のキャストがだいぶ煩雑になってしまうのが玉に瑕だ。

詳細なコードは以下のgistにある。
gist0b9f189fd5cf0550903e