MixJuice をサーバー化して paprika ロボットを動かす

1. はじめに

IchigoJam などの シリアル通信機器から利用できる ネットワークボード MixJuice ですが、 HTTPクライアント機能に加え、HTTPサーバ機能にも対応してみました。(現状はベータ版。)

MixJuice にPOSTでデータを送信するとシリアル通信のTXDに転送されるようになりました。

下記よりダウンロードしてファームウエアを書き換えてお試しいただけます。
http://mixjuice.shizentai.jp/MixJuice.1.3b1.zip

2. 試し方

今回追加したコマンドは下記です。

SERV START:
HTTPサーバの起動。(デフォルトポート: 80, 追加のパラメータで変更可)

SERV STOP:
HTTPサーバの停止。

SERV NAME ****:
mDNS名の設定。(デフォルト値: “mixjuice”, ****.local の ****部分を指定)

IchogoJam BASIC の場合、下記のようなプログラムでHTTPサーバが起動します。

10 ?"MJ APC ******** ********"
20 ?"MJ SERV START"

データの送信先となる MixJuice の IPアドレス はDHCPで自動的に割り当てられますが、4. MixJuice の IPアドレスの調べ方 を参考にご確認ください。
※ macOS や iOS、Windows 10(1809以降) を使っている場合、mixjuice.local 等のDNS名でアクセスできる場合があります。

データ送信を試すには、MixJuice と同じLANに属するパソコンで下記のようなコマンドを発行します。

macOS/Linux の端末から(LEDをONにする、文字列を送信する)

$ curl -X POST -d payload=LED1%0A http://[MixJuiceのIPアドレス]
$ curl -X POST -d "payload='Hello,World!%0A" http://[MixJuiceのIPアドレス]

Windows のPowerShellから(LEDをONにする、文字列を送信する)

> Invoke-RestMethod -Method POST -Body payload=LED1%0A -Uri http://[MixJuiceのIPアドレス]
> Invoke-RestMethod -Method POST -Body "payload='Hello,World!%0A" -Uri http://[MixJuiceのIPアドレス]

3. サンプルアプリケーション

paprika ロボットを動作させるサンプルアプリケーションはこちらです。
http://mixjuice.shizentai.jp/webapps/1.3b1_robo_c/

MixJuice URL: に http://[MixJuiceのIPアドレス] を入力した状態で矢印のボタンなどをタップ/クリックすると、ロボットを制御するOUTコマンドがIchigoJamに送られます。
※ macOS/iOSのSafari や Windows 10(1809以降)など、mDNSに対応した動作環境では mixjuice.local 等のDNS名が利用できる場合があります。

動作環境ごとのmDNS対応状況(筆者確認分)
macOS (10.12) / Safari
macOS (10.12) / Chrome×
macOS (10.12) / Firefox
Windows 10 (1809) / Edge
Windows 10 (1809) / Chrome
Windows 10 (1809) / Firefox
Windows 10 (1803) / Edge×
Windows 10 (1803) / Chrome×
Windows 10 (1803) / Firefox×
iOS (8.1.2) / Safari
Android (8.1) / Chrome×

4. MixJuice の IPアドレスの調べ方

I. 接続時に画面で確認する(IchigoJamなど)

MixJuice は APCコマンドの成功時に自機に割り当てられたIPアドレスを報告するので、 IchigoJam の画面などで確認できます。
割り当てられるIPアドレスは起動毎に変わる可能性がありますが、一般的に一定時間内は同じ機材(MACアドレス)には同じIPアドレスが割り当てられることが多いため、ロボット等に載せる前にIchigoJam の画面で確認しておくことができます。

II. mDNSを使って確認する(macOS/Windowsの一部のバージョン)

MixJuice は mDNSに対応しているため、同じく対応している macOS や iOS、Windows 10(1809以降) からはDNS名でアクセスすることができます。
また、DNS名でのアクセスがおそい場合は、下記のコマンドでDNS名からIPアドレスを確認してIPアドレスでアクセスしてもよいでしょう。

macOS の ターミナル から

$ dns-sd -G v4 mixjuice.local

Windows 10(1809以降) の PowerShell から

> Resolve-DnsName mixjuice.local

III. ARP を使って確認する

パソコン等は自機が属するLAN内の機器のMACアドレスとIPアドレスの組み合わせ表(ARPテーブル)を 管理しているので、ARP関連のコマンドを使って確認できます。
MixJuice の MACアドレスは MACコマンドで確認できます。

?"MJ MAC"

ARPテーブルには最近通信した機器の情報のみ保持されるため、事前にマルチキャストでpingを打つなどの準備が必要になりますが、下記が参考になるでしょう。(上級者向け)
http://d.hatena.ne.jp/nattou_curry_2/20090906/1252203651

5. まとめと課題

  • MixJuice に HTTPサーバ機能を追加したのでロボットの操作などに使えるようになりました。
  • 現状、IPアドレスを調べるのが少し大変ですが、環境は改善されてきています。
  • IPアドレスを調べるツールを探すか作りたい。
  • mDNSやARPについてもっと詳しくなりたい。
  • パソコン: 最新の環境に限れば、Scratch 対応できそう。
  • スマホ/タブレット: iOSとWindowsに限れば、Scratch 対応できそう。

シリアル通信とブラウザJavaScriptをブリッジする IchigoLink

この記事は、IchigoJam Advent Calendar 2018 8日目の記事です。

1. はじめに

IchigoLink は Scratch 3.0 と IchigoJam を連携させるために開発している、
シリアル通信とブラウザJavaScriptのブリッジです。

Windows, Mac, Linux でコマンドラインアプリケーションとして動作し、
WebSocket を使って ローカルのシリアルポート と ブラウザのJavaScriptをつなぎます。
(ちなみに、micro:bit は同様のツールの BLE版を提供しています。)

本来は Scratch連携用 のツールですが、それ以外にも面白いことができます。

2. 何ができるのか

下記の動画にあるような IchigoJamと連携する作品を JavaScript と HTML だけで作成できます。

IchigoJam  のボタン操作でWebページを変化させる

IchigoJam から取得したアナログ値で Webページを変化させる

WebページからIchigoJam を操作する

3. [使い方] 準備するもの

  • パソコン
  • IchigoJam
  • シリアル通信に必要なデバイス(USBシリアル変換アダプタなど)
  • IchigoJamで使いたいデバイス(LED、ボタン、可変抵抗、各種センサー、各種モーターなど)

4. [使い方] ダウンロードから起動まで

開発中ということで仮の場所になりますが、下記からダウンロードできます。
http://shizentai.jp/ichigolink/
IchigoLink は下記からダウンロードできます。
http://ichigolink.shizentai.jp/downloads.html

zip ファイルを解凍すると下記のような中身になっているので、コマンドプロンプトやターミナルを立ち上げて、このディレクトリに移動します。

パソコンとシリアル通信デバイス、IchigoJamを接続します。
参考: イチゴジャム レシピ — 周辺機器 パソコンと接続

下記のコマンドをたたきます。

Windows の場合

> ichigo-link [シリアルデバイス名]

Mac/Linux の場合

$ ./ichigo-link [シリアルデバイス名]

シリアルデバイス名は Windows の場合はCOM3やCOM4、Linux の場合は /dev/ttyUSB0 などになることが多いようです。
参考: IchigoLink: Find serial port

コマンドプロンプトやターミナルが上のような表示になり、
ブラウザで、 http://localhost:30110 を表示したときに下記のような画面になれば起動成功です。箇条書き程度ですが、仕様をまとめてあるので参考にしてください。

また、このページが ichigo-link-www フォルダの index.html に対応しており、ichigo-link-www フォルダ以下にファイルを置くと、localhost:30110 以下で公開されるようになっています。

5. [使い方] 付属デモアプリケーション

デモツールとして、簡易的なターミナルとコード送信ツールを添付しています。
ichigo-link-www/demo の下にファイルが存在します。

簡易ターミナル

http://localhost:30110/demo/terminal.html

connect ボタンを押すと接続します。
上のテキストボックスに入力したものを行単位で送信し、受信したものを下のテキストエリアに表示します。
RUNを中断したいときなどに esc ボタンを押してエスケープシーケンスも送れます。

現状、テキストエリアにデータを追加しているだけで解放処理をしていないので、
大量のデータを受け取ったり、長時間使用すると固まったりするかもしれません。あしからず。

コード送信ツール

http://localhost:30110/demo/send_source.html

まとめて何行か送りたいとき用のツールです。

6. 動画で紹介した作品の作り方

下記のソースコードをテキストエディタなどに貼り付けて、ichigo-link-www 以下に適当なファイル名で保存すれば、localhost:30110 以下でブラウザからアクセスできます。

IchigoJam 側のプログラムを最初に送って RUNするようにしていますが、この部分だけ IchigoJam 側に最初から用意しておいてもよいと思います。

IchigoJam のボタンを押すと背景色がつくページ

<!DOCTYPE html>
<html>
<head>
  <title>IchigoJamのボタンを押すと緑になるページ</title>
  <meta charset="UTF-8"/>
  <script>
    window.addEventListener('load', function () {
      var ws = new WebSocket('ws://localhost:30110/serial');
      ws.addEventListener('open', function () {
        ws.send(JSON.stringify({"type":"esc"}));
        ws.send(JSON.stringify({"type":"text","value":"NEW"}));
        ws.send(JSON.stringify({"type":"text","value":"10 ?BTN():WAIT3:GOTO10"}));
        ws.send(JSON.stringify({"type":"text","value":"RUN"}));
      });
    
      ws.addEventListener('message', function (event) {
        var obj = JSON.parse(event.data);
        if(obj.value == "0") {
          document.body.style.backgroundColor = "white";
        }
        if(obj.value == "1") {
          document.body.style.backgroundColor = "#00C000";
        }
      });
    
    });
  </script>
</head>
<body>
    <h2>IchigoJamのボタンを押すと画面が緑になるページ</h2>
  
</body>
</html>

ANA(2)の値で背景色の濃さが変わるページ

背景色の計算ロジック、地味に苦労しました。改善求む!

<!DOCTYPE html>
<html>
<head>
  <title>ANA(2)の値で緑の濃さが変わるページ</title>
  <meta charset="UTF-8"/>
  <script>
    window.addEventListener('load', function () {
      var ws = new WebSocket('ws://localhost:30110/serial');
      ws.addEventListener('open', function () {
        ws.send(JSON.stringify({"type":"esc"}));
        ws.send(JSON.stringify({"type":"text","value":"NEW"}));
        ws.send(JSON.stringify({"type":"text","value":"10 ?ANA(2):WAIT3:GOTO10"}));
        ws.send(JSON.stringify({"type":"text","value":"RUN"}));
      });
    
      ws.addEventListener('message', function (event) {
        var obj = JSON.parse(event.data);
        var a = parseInt(obj.value,10);
        var b = Math.floor(a/2);
        var c, d;
        if ( b < 256 ) {
	  c = 255 - b;
	  d = 255;
        } else {
	  c = 0;
	  d = 255 - (b-255);
        }
	var color = "rgb(" + c + "," + d + "," + c + ")";
	console.log(color);	 
	document.body.style.backgroundColor = color;
      });
    
    });
  </script>
</head>
<body>
    <h2>ANA(2)の値で緑の濃さが変わるページ</h2>
  
</body>
</html>

LEDとPWMをコントロールするページ

<!DOCTYPE html>
<html>
<head>
  <title>IchigoJamのLEDとPWMをコントロールするページ</title>
  <meta charset="UTF-8"/>
  <script>
    window.addEventListener('load', function () {
      var ws = new WebSocket('ws://localhost:30110/serial');
      ws.addEventListener('open', function () {
        ws.send(JSON.stringify({"type":"esc"}));
        ws.send(JSON.stringify({"type":"text","value":"LED0"}));
        ws.send(JSON.stringify({"type":"text","value":"PWM3,50"}));
        ws.send(JSON.stringify({"type":"text","value":"PWM4,50"}));
        document.getElementById('ledon').addEventListener('click',function() {
          ws.send(JSON.stringify({"type":"text","value":"LED1"}));
        });
        document.getElementById('ledoff').addEventListener('click',function() {
          ws.send(JSON.stringify({"type":"text","value":"LED0"}));
        });
        document.getElementById('pwm3').addEventListener('change',function() {
          var a = parseInt(document.getElementById('pwm3').value,10);
          ws.send(JSON.stringify({"type":"text","value":"PWM3," + a}));
        });
        document.getElementById('pwm4').addEventListener('change',function() {
          var a = parseInt(document.getElementById('pwm4').value,10);
          ws.send(JSON.stringify({"type":"text","value":"PWM4," + a}));
        });
      });
    });
  </script>
</head>
<body>
  <h1>IchigoJamのLEDとPWMをコントロールするページ</h1>
  <form>
    <h3>LED</h3>
    <input type="radio" name="led" id="ledon" />On
    &nbsp;
    <input type="radio" name="led" id="ledoff" checked="checked"/>Off
    
    <h3>PWM3</h3>
    50 <input type="range" id="pwm3" value="0" min="50" max="240" step="10"/> 240
    
    <h3>PWM4</h3>
    50 <input type="range" id="pwm4" value="0" min="50" max="240" step="10"/> 240

  </form>

  
</body>
</html>  

7. まとめと課題

  • IchigoLink を使うと IchigoJam と連携するブラウザアプリケーションを簡単に作れます。
  • Scratch 対応として配布するまでに GUI化したいです。
  • Windows 版の反応がよくない気がするのが少々気になる。
  • IchigoLink 公式サイトhttp://ichigolink.shizentai.jp/

IchigoJam BASIC RPi を USBメモリから起動する

IchigoJam BASIC RPi を USBメモリ から起動。 意外と簡単でした!

準備物

USBメモリからの起動には、Pi 3から対応しているようです。

  • Raspberry Pi 3 Model B
  • IchigoJam BASIC RPi を コピーした micro SDカード
  • IchigoJam BASIC RPi を コピーした USBメモリ

ご注意!

config.txt に program_usb_boot_mode=1 を追加して起動することで、ラズパイの OTP memory という領域が書き換えられて、USBメモリからのブートが可能になるとのこと。ただ、この設定は元に戻すことができないとのこと。試してみる方は自己責任でお願いします!

やりかた

基本的には、下記を参考にすればOKです。
HOW TO BOOT FROM A USB MASS STORAGE DEVICE ON A RASPBERRY PI 3

  1.  micro SDカード の config.txt の最後に  program_usb_boot_mode=1 を追加する
  2.  micro SDカード から一旦起動する
  3.  micro SDカード を抜いて、 USBメモリ を差して起動する
  4.  micro SDカード の config.txt を元に戻す(お忘れなく)

その他

  • USBメモリから起動するときは、いつもより少し時間がかかります。
  • だめもとで USBハードディスク(USB3.0, 500GB)でも試してみましたが、成功しませんでした。なにか工夫すればできるのかも。
  • 大きな領域が使えるとなると、IchigoJam BASIC にもファイルの WRITE/READ が欲しくなってきますね。

ラズパイ版 IchigoJam でアナログ入力

この記事は、IchigoJam Advent Calendar 2017 8日目の記事です。

1. はじめに

LPC1114版 IchigoJam にあって ラズパイ版にないものはけっこうあります。

  • ディスプレイ関連機能 (VIDEO/SWITCH コマンド)
  • サウンド関連機能 (BEEP/PLAY/TEMPO/SOUND コマンド)
  • マシン語関連機能 (USR コマンド)
  • 省電力機能 (SLEEP コマンド)
  • アナログ入力 (ANA コマンド)

その中でもとくに重要なアナログ入力ですが、今後も本体への実装は厳しそうなので、
回避策をご紹介したいと思います。

今回は、I2C通信対応のADコンバータを外部接続し、
ラズパイ版の IchigoJam BASIC でアナログ入力を実現してみます。

とはいえ、アナログ入力が使えないという課題自体は、Raspbian などのOSで
Raspberry Pi を利用している人にも共通しているため、ネット上にたくさんの情報がありました。

特にこちらの記事がとてもわかりやすく参考になりました。
http://kinokotimes.com/2017/02/02/python-mcp3425-16bits/

2. 準備物

Raspberry Pi本体

今回はPi3で試しました。

ADコンバータ

MCP3425というADコンバータのDIP化モジュールを秋月電子さんで購入しました。
http://akizukidenshi.com/catalog/g/gK-08018/

アナログセンサ

弊社によく転がっているシャープ製 測距センサ GP2Y0A02YK を使いました。
http://akizukidenshi.com/catalog/g/gI-03158/

3. ADコンバータの仕様

I2Cアドレス

上位4bit がデバイスアドレスで 0b1101
下位3bit は発注時に指定がなければ 0b000
ということなので、普通に購入した場合、0b1101000 = 0x68 になります。

設定の書き込み

1バイト送信して設定を行います。
bit7: 1に固定
bit4: (1:設定後、連続して読み取り可能; 0: 読み取りのたびに設定必要;)
bit3,2: (0b00:12ビット値を取得; 0b01:14ビット値を取得; 0b10:16ビット値を取得;)

今回は連続読み取り、12bitモードを試しました。(0b10010000)

電圧の読み取り

2バイト受信して読み取ります。(コマンドは0x00)
0バイト目: 上位8bit(右詰め)
1バイト目: 下位8bit

12bit,14bit,16bit の各先頭のビットは符号ビットなので、
実際の数値は 11bit, 13bit, 15bit マスクして取得するようです。

4. 配線

下記の接続でうまくいきました。(あとで図を載せたいです!)

測距センサ

VDD — RPi(5V)
VSS — RPi(GND)
VO — ADC(VIN+)

ADコンバータ

VIN+ — センサー(VO)
VIN- — RPi(GND)
VSS — RPi(GND)
VDD — RPi(3.3V)
SCL — RPi(SCL)
SDA — RPi(SDA)

5. BASIC コード

下記のコードで、なんとなくそれらしい値が取得できました。

10 POKE #700,`10010000
20 POKE #701,#00
30 R=I2CW(#68,#700,1)
40 R=I2CR(#68,#701,1,#702,2)
50 ?((PEEK(#702)<<8)|PEEK(#703))&`11111111111
60 WAIT5:GOTO40

6. 今後の課題

  • 14bitモードや16bitモードも試してみましたが、うまくいきませんでした。
  • 下位3bitのI2Cアドレスを指定できれば、切り替えて複数アナログ入力もできるかもしれません。

Haskell(wai) による Webアプリケーション開発の実際(DB編)

この記事は、スタートトゥデイ工務店 Advent Calendar 14日目の記事です。

wai(Haskell製のWebアプリケーション規格)に準拠し、warp(wai準拠のHaskell製Webサーバ)上で動作するWebアプリケーションの開発について紹介する。基本性能を際立たせるため、便利なフレームワークはあえて使用しない。

以前に非常に単純なサンプルを紹介した記事の続編となる。
今回は、本格的なWebアプリケーションに欠かせない、データベースとの連携を試してみた。
バックエンドにはMySQLを使用した。

ソースコードは https://github.com/mitsuji/wai-example-mysql にある。

1. サンプルアプリケーションの概要

下記のようなデータを扱うJSON-APIを実装した。
1件のコーディネートに対して、ジャンルが1つ、タグが複数(0..N)紐づくものとする。

オブジェクト図は下記のようになるだろう。

また、MySQLのCREATE文は下記のようになる。

CREATE TABLE genre (
        genre_id INT NOT NULL AUTO_INCREMENT
       ,genre_title nvarchar(31) NOT NULL
       ,PRIMARY KEY (genre_id)
);


CREATE TABLE tag (
        tag_id INT NOT NULL AUTO_INCREMENT
       ,tag_title nvarchar(31) NOT NULL
       ,PRIMARY KEY (tag_id)
);


CREATE TABLE look (
        look_id INT NOT NULL AUTO_INCREMENT
       ,look_create_dt DATETIME NOT NULL
       ,look_update_dt DATETIME NOT NULL
       ,look_title nvarchar(31) NOT NULL
       ,look_description nvarchar(400) NOT NULL
       ,look_genre_id INT NOT NULL
       ,PRIMARY KEY (look_id)
       ,FOREIGN KEY (look_genre_id) REFERENCES genre (genre_id)
);

CREATE TABLE look_has_tag (
        lht_look_id INT NOT NULL
       ,lht_tag_id INT NOT NULL
       ,PRIMARY KEY (lht_look_id,lht_tag_id)
       ,FOREIGN KEY (lht_look_id) REFERENCES look (look_id)
       ,FOREIGN KEY (lht_tag_id) REFERENCES tag (tag_id)
);

Haskellのデータ定義は下記のようになった。

data Genre = Genre GenreId Title [Look]
           deriving (Eq)

data Tag = Tag TagId Title [Look]
         deriving (Eq)

data Look = Look { lookId :: LookId
                 , lookCreateDt :: CreateDT
                 , lookUpdateDt :: UpdateDT
                 , lookTitle :: Title
                 , lookDescription :: Description
                 , lookGenre :: Genre'
                 , lookTags :: [Tag']
                 }
          deriving (Eq)


newtype Genre' = Genre' Genre
               deriving (Eq)
                        
newtype Tag' = Tag' Tag
               deriving (Eq)

2. 実装の方針

下記の方針で実装した。
* mysql-simpleを使用してMySQLのデータをHaskellのデータに変換する。
* aesonを使用してHaskellのデータをJSONに変換する。
* waiを使用してWebのインターフェースを提供する。

また、実用的なサンプルとするため、下記を盛りこんだ。
* トランザクション処理
* コネクションプール
* N対Nのリレーション

3. MySQLのデータをHaskellのデータに変換する。

mysql-simple では QueryResult という型クラスが用意されており、
任意のデータ型をこの型クラスのインスタンスにすることで、
MySQLに投げたクエリの結果をHaskellのデータに変換することができる。
下記のように convertResults を実装すればよい。

instance QueryResults Genre' where
  convertResults [fa,fb] [va,vb] = Genre' $ Genre a b []
        where !a = convert fa va
              !b = convert fb vb
  convertResults fs vs  = convertError fs vs 2

上記を定義すると、下記のようにクエリを投げることができる。
結果は、関数の型からも分かるように Genre’ のリストとして取り出すことができる。

select_genre :: Connection -> IO [Genre']
select_genre conn =
  query_ conn [r|
    SELECT
       genre_id
      ,genre_title
    FROM genre
    ORDER BY genre_id
  |]

4. HaskellのデータをJSONに変換する。

aeson では ToJSON という型クラスが用意されており、
任意のデータ型をこの型クラスのインスタンスにすることで、
JSONへの変換を定義することができる。
下記のように toJSON を実装すればよい。

instance ToJSON Tag where
  toJSON (Tag id t ls) =
    object ["id" .= id
           ,"title" .= t
           ,"looks" .= ls
           ]

ソースコードのプロジェクトにREPLで入ると、
下記のようにaesonの動作を試すことができる。

*Main Data JSON MySQL> AE.encode $ Tag 100 "タグ100" []
"{\"looks\":[],\"id\":100,\"title\":\"\227\130\191\227\130\176\&100\"}"

5. コネクションプール

コネクションプールはresouce-poolというライブラリを使用して実装した。
このライブラリを使うと、DBの接続に限らず任意のリソースのプールを簡単に実装することができるようだ。

アプリケーション起動時に createPool でプールを作っておく。
createPool にはプールにリソースが確保されるときの処理、プールからリソースが開放されるときの処理と、プールのチューニングに関するいくつかのパラメータを設定する。

main :: IO ()
main = do
  host:port:_ <- getArgs
  cp <- createPool connect close 10 10 10
  Warp.runSettings (
    Warp.setHost (fromString host) $
    Warp.setPort (read port) $
    Warp.defaultSettings
    ) $ routerApp cp
  where
    connect :: IO MySQL.Connection
    connect = MySQL.connect MySQL.defaultConnectInfo {
       MySQL.connectHost = "localhost"
      ,MySQL.connectUser = "wai_exam_admin"
      ,MySQL.connectPassword = "abcd1234"
      ,MySQL.connectDatabase = "wai_exam"
      }
    close = MySQL.close

リソースプールの変数を引き渡しておけば、アプリケーションの任意の箇所で
withResource を使用して、プール内のリソースを使うことができる。
関数の呼び出しが深くなる場合は、リソースプールの共有に
Readerモナドなどを使うとよいだろう。

  -- GET /v1/genre
  (Right M.GET, [_,_]) -> do
    bs <- AE.encode <$> (withResource cp $ \conn -> select_genre conn)
    respond $ response200 bs

6. トランザクション処理

トランザクション処理は下記のように withTransaction を使うだけで実現されるようだ。

delete_look :: Connection -> LookId -> IO ()
delete_look conn id =
  withTransaction conn $ do
    execute conn
      "DELETE FROM look_has_tag WHERE lht_look_id = ?" (Only id)
    execute conn
      "DELETE FROM look WHERE look_id = ?" (Only id)
    return ()

7. ルーティング

URLのパスやHTTPメソッドの種類と、評価される関数をどのように紐づけるか。
wai が Text型のリストとしてURLのパスを提供してくれているので、
下記のようにパターンマッチを使ってルーティングを定義することができた。
フレームワークを使った場合ほどではないが、比較的簡潔にできた。

routerApp :: Pool MySQL.Connection -> Wai.Application
routerApp cp req respond = case Wai.pathInfo req of
  "v1" : _ -> (v1App cp req respond) `catch` onException -- /v1{var}
  _ -> staticApp req respond -- static html/js/css files
  where
    onException :: SomeException -> IO Wai.ResponseReceived
    onException (SomeException e) = respond $ responseNG 5000 "unknown error"
--    onException (SomeException e) = respond $ responseNG 5000 $ displayException e


v1App :: Pool MySQL.Connection -> Wai.Application
v1App cp req respond = case Wai.pathInfo req of
  _ : "genre"  : _ -> genreApp cp req respond -- /v1/genre{var}
  _ : "tag"    : _ -> tagApp cp req respond   -- /v1/tag{var}
  _ : "look"   : _ -> lookApp cp req respond  -- /v1/look{var}
  _ -> staticApp req respond -- static html/js/css files

HTTPメソッドも合わせてパターンマッチすれば、RESTっぽいことも簡単にできる。

genreApp :: Pool MySQL.Connection -> Wai.Application
genreApp cp req respond = case (M.parseMethod (Wai.requestMethod req), Wai.pathInfo req) of
  
  -- POST /v1/genre
  (Right M.POST, [_,_]) -> do
    ps <- parseForm req
    case lookupParam "title" ps of
      Nothing -> respond $ responseNG 5101 "invalid title"
      Just t -> do
        bs <- AE.encode <$> (withResource cp $ \conn -> create_genre conn t)
        respond $ response200 bs
             
  -- DELETE /v1/genre/{id}
  (Right M.DELETE, [_,_,id]) ->
    case readMaybe (T.unpack id) of
      Nothing -> respond $ responseNG 5102 "invalid id"
      Just id -> do
        withResource cp $ \conn -> delete_genre conn id
        respond responseOK
    

8. SQLインジェクション防止機能

mysql-simple では SQLインジェクションを防止するため、query や query_ には
文字列のリテラルでSQL文を渡さなければならないようにしてあるようだ。

文字列結合を使ってSQL文を組み立てることができないため、
条件を任意で指定するSELECT文が少し作りにくかったが、
下記のようにすることで対応できた。

-- [TODO] sanitize param of LIKE phrase 
select_look :: Connection -> Maybe Title -> Maybe Description -> Maybe GenreId -> Maybe TagId -> IO [Look]
select_look conn mt md mgid mtid = do

  (ft,t) <- case mt of
    Nothing -> return (1::Int,"%")
    Just t ->  return (0::Int,t)
    
  (fd,d) <- case md of
    Nothing -> return (1::Int,"%")
    Just d ->  return (0::Int,d)

  (fgid,gid) <- case mgid of
    Nothing ->  return (1::Int,0)
    Just gid -> return (0::Int,gid)

  (ftid,tid) <- case mtid of
    Nothing ->  return (1::Int,0)
    Just tid -> return (0::Int,tid)

  ls <- query conn [r|
    SELECT
       look_id
      ,look_create_dt
      ,look_update_dt
      ,look_title
      ,look_description
      ,genre_id
      ,genre_title
    FROM look
      LEFT OUTER JOIN genre ON look_genre_id = genre_id
    WHERE 1 = 1
      AND (1=? OR look_title LIKE ?)
      AND (1=? OR look_description LIKE ?)
      AND (1=? OR look_genre_id = ?)
      AND (1=? OR look_id IN
                  (SELECT lht_look_id FROM look_has_tag WHERE lht_tag_id =?))
    ORDER BY look_id
  |](ft,t,fd,d,fgid,gid,ftid,tid)

  tags <- select_tag_for_looks conn ls
  return $ merge_tags tags ls

9. まとめ

  • mysql-simple などのライブラリを使えば DBのデータとHaskellのデータのマッピングは簡単。
  • aeson を使えば Haskellのデータを JSON化するのは簡単。
  • resource-pool を使えばコネクションプールの導入は簡単。
  • mysql-simple のトランザクション処理は簡単確実。
  • Webアプリケーションのパス/メソッドルーティングは単純なパターンマッチでもある程度可能。
  • mysql-simple を使えば SQLインジェクションの危険性が低下。

10. 今後の課題

  • mysql-simple 以外のDBライブラリもいろいろ試してみたい。
  • 入力のバリデーションをもっとちゃんと実装してみたい。
  • ファイルのアップロードも試してみたい。
  • フロントエンドを実装して、実際に使ってみたい。

Haskell で 覆面算

Haskell で 覆面算 をやってみた。

DEBT + STAR = DEATH が与えられたとき、等式が成立するには
D = 1, E = 0, B = 8, T = 5, S = 9, A = 6, R = 7, H = 2
とならなければならない、という問題を解くものである。
先日とある脱出ゲームで出題されたが手計算ではまったく解けなかった。

ソースコードはこちら。
https://github.com/mitsuji/verbal-arithmetic

1. 特殊解

まずは、特殊ケースとして "DEBT + STAR = DEATH" だけを解くことを考える。
リストの要素を指定された数だけ使用した全ての順列に評価される関数
permutation を 作ると、下記のように総当りで解くことができる。

単語の先頭の数字はゼロにならないので、D != 0 と S != 0 を条件に追加している。


matchDeath :: [Int] -> Bool
matchDeath (a:b:d:e:h:s:t:r:[]) =
  d/=0 && s/=0 && debt + star == death
  where
    debt  =             d * 1000 + e * 100 + b * 10 + t
    star  =             s * 1000 + t * 100 + a * 10 + r
    death = d * 10000 + e * 1000 + a * 100 + t * 10 + h

filterDeath =
  map (zip "abdehstr") $ filter matchDeath  $ permutation 8 [0,1,2,3,4,5,6,7,8,9]

また、繰り上がりを考えると等式を見ただけで D = 1 が明らかなので、
これを条件に加えると、試行回数が激減して実行時間を短縮できる。


matchDeath' :: [Int] -> Bool
matchDeath' (a:b:e:h:s:t:r:[]) =
  debt + star == death
  where
    debt  =             d * 1000 + e * 100 + b * 10 + t
    star  =             s * 1000 + t * 100 + a * 10 + r
    death = d * 10000 + e * 1000 + a * 100 + t * 10 + h
    d = 1

filterDeath' =
  map (zip "abehstr")  $ filter matchDeath' $ permutation 7 [0,2,3,4,5,6,7,8,9]

2. 一般化

ここからが本番だ。

脱出ゲームに勝つためには、わざわざ関数を書かなくても、
例えば下記のように記述したら解答を表示してくれるライブラリが必要だ。


test1 = print $ findConditions $ "debt" + "star" == "death"

test2 = print $ findConditions $ "debt + star = death"

また、このような関数をあらかじめコンパイルしておけば、


main = do
  equ:_ <- getArgs
  print $ findConditions $ fromString equ

このように、コマンドにパラメータを渡すだけで解答を得ることができるだろう。


$ verbal-arithmetic-general-exe "debt + star = death"

3. 式のデータ

まずは、入力となる数式(文字式?)を表現するためのデータ型を考えてみる。
今回は式(VExp)と等式(VEqu)を別の型として定義してみた。


data VExp = Val [Char]
          | Add VExp VExp
          deriving(Show)

data VEqu = Equals VExp VExp
          deriving(Show)

このデータ型を使用すると、
式 DEBT + STAR = DEATH は下記のようなデータになる。
ポーランド記法とかいうやつだ。


equ1 = Equals (Add (Val "debt") (Val "star")) (Val "death")

関数を演算子として使えば、下記のように書くこともできる。


equ2 = Val "debt" `Add` Val "star" `Equals` Val "death"

ここで、下記の関数を定義してみると、

(+)  = Add
(==) = Equals

下記のような記述が可能になる。だいぶ見やすくなってきた。


equ3 = Val "debt" + Val "star" == Val "death"

そして、VExp を IsString 型クラスのインスタンスにして、


instance IsString VExp where
  fromString xs = Val xs
  

ソースコードの先頭に {-# LANGUAGE OverloadedStrings #-} を書くと
下記のような記述が可能になる。
これは、コード上に文字列リテラルがあり、VExp型に推論されるときは
VExp の fromString を使って、VExp型のデータを作りなさいという意味である。
コード上で式を扱うには、まずはこれで充分だろう。


equ4 = "debt" + "star" == "death"

4. 一般解

特殊解の関数を参考にして作成した関数が下記である。
chars 関数で式内のユニークな文字を抽出し、総当りの場合の数を決めている。
また、firstChars 関数で式内の単語の先頭の文字を抽出し、!= 0 条件を追加している。


findConditions :: VEqu -> [[(Char,Int)]]
findConditions equ =
  let
    cs = chars equ
  in
   filter (match equ) $ map (zip cs) $ permutation (length cs) [0..9]


match :: VEqu -> [(Char,Int)] -> Bool
match equ xs = (and $ map f $ firstChars equ) && evaluate equ xs
  where
    f x =
      let Just y = lookup x xs
      in  y /= 0

match 関数に渡された数字を元に実際に計算を行う関数は下記のようになった。
listToInt 関数は、数字のリストを10進数で数値に変換する関数である。


evaluate :: VEqu -> [(Char,Int)] -> Bool
evaluate (Equals exp1 exp2) xs = expEvaluate exp1 xs P.== expEvaluate exp2 xs 
  where
    expEvaluate :: VExp -> [(Char,Int)] -> Int
    expEvaluate (Add exp1 exp2) xs = expEvaluate exp1 xs P.+ expEvaluate exp2 xs
    expEvaluate (Val cs) xs = listToInt $ map f cs
      where
        f x =
          let Just y = lookup x xs
          in  y

5. パーサー

ここまでで計算自体はできるようになったが、コマンドラインに式を渡せるようにするには、
式全体を文字列として受け取って、式のデータに変換するパーサーを書く必要がある。

こんな感じのパーサーになった。スペースの扱いで1日くらいハマった。


pVal :: PS.Parser VExp
pVal = do
  xs <- PS.many1 $ PS.letter <|> PS.alphaNum
  return $ Val xs

pAdd :: PS.Parser (VExp -> VExp -> VExp)
pAdd = PS.char '+' >> return Add

pExp :: PS.Parser VExp
pExp = pValS `PS.chainl1` pOpS
  where
    pValS = do
      val <- pVal
      PS.spaces
      return val
    pOpS = do
      op <- pAdd <|> mzero
      PS.spaces
      return op

pEquals :: PS.Parser VEqu
pEquals = do
  exp1 <- pExp
  PS.char '='
  PS.spaces
  exp2 <- pExp
  return $ Equals exp1 exp2

最後に VEqu を IsString のインスタンスにして
式全体を文字列として記述し、直接式のデータとして扱えるようにした。


instance IsString VEqu where
  fromString xs =
    case PS.parse pEquals "verbal" xs of
      Right equ -> equ
      Left  err -> error (show err)

6. まとめ・感想

  • 実行形式バイナリにコンパイルすればHaskellでもそこそこ速かった。
  • IsString 型クラスを使うと、いろんな型のデータを文字列リテラルから作れる。
  • パーサーを書くときはスペースの処理が重複しないように注意しないとハマる。
  • 式の表現は完璧なので、計算のアルゴリズムを改善してみたい。非総当りとか。
  • 引き続き、掛け算と引き算くらいまでは対応してみたい。

Haskell(wai) による Webアプリケーション開発の実際

2016年12月追記: この記事のDB(MySQL)編はこちら

wai(Haskell製のWebアプリケーション規格)に準拠し、warp(wai準拠のHaskell製Webサーバ)上で動作するWebアプリケーションの開発手順をまとめる。基本性能を際立たせるため、便利なフレームワークはあえて使用しない。

1. サンプルアプリケーションの概要

サーバの現在時刻をクライアント側で装飾して表示するWebアプリケーション。動作サンプルは下記を参照。

http://mitsuji.org:9997/

このアプリケーションは、下記のエンドポイントからなる。

  • /posixtime — GETでサーバの現在のUNIX時間(ミリ秒単位)を返す。
  • /main.html — 画面のHTML。クライアント側のエントリポイント。
  • /main.js — main.html で読み込まれる JavaScript。posixtime をGETして装飾してから画面に表示する。

2. 開発環境(stack) の準備

下記から stack をダウンロードしてインストールする。解凍してPATHを通すだけでよい。

http://docs.haskellstack.org/en/stable/README.html

下記のようにバージョンが表示できれば準備完了。

$ stack --version
Version 1.0.2, Git revision fa09a980d8bb3df88b2a9193cd9bf84cc6c419b3 (3084 commits) x86_64

3. サンプルアプリケーションのコードの取得

コードは下記に置いてある。

https://github.com/mitsuji/wai-example

ソースコードを clone して、

$ git clone https://github.com/mitsuji/wai-example.git
Cloning into 'wai-example'...
remote: Counting objects: 12, done.
remote: Compressing objects: 100% (10/10), done.
remote: Total 12 (delta 0), reused 12 (delta 0), pack-reused 0
Unpacking objects: 100% (12/12), done.
Checking connectivity... done.

ディレクトリに cd してから、

$ cd wai-example/

下記のコマンドを叩くとghc(Haskellのコンパイラ)などの環境が自動的に準備される。いろいろとダウンロードされるため、初めての時は少し時間がかかるかもしれない。

$ stack setup

ディレクトリ内のファイルのうち、開発に直接関係があるのは下記の三つだけである。

  • app/Main.hs — Webアプリケーション本体のソースコード。
  • static/main.html — Webアプリケーション動作時にアクセス可能となる main.html そのもの。
  • static/main.js — Webアプリケーション動作時にアクセス可能となる main.js そのもの。

4. REPL(ghci) を使用した動作確認

下記のコマンドでHaskell の REPL である ghci に入ることが出来る。

$ stack ghci
The following GHC options are incompatible with GHCi and have not been passed to it: -threaded
Using main module: 1. Package `wai-example' component exe:wai-example-exe with main-is file: /home/mitsuji/Downloads/hoge/wai-example/app/Main.hs
Configuring GHCi with the following packages: wai-example
GHCi, version 7.10.2: http://www.haskell.org/ghc/  :? for help
[1 of 1] Compiling Main             ( /home/mitsuji/Downloads/hoge/wai-example/app/Main.hs, interpreted )
Ok, modules loaded: Main.
*Main>

REPLを使用すると、ソースコード内の関数を直接評価することが出来る。例えば、Main.hs内のこの関数は

getPOSIXTime' :: IO Int
getPOSIXTime' = do
  pt_seconds <- getPOSIXTime
  return $ truncate $ pt_seconds * 1000

このようにして直接評価してみることが出来る。

*Main> getPOSIXTime'
1455622245689

ソースコードを書き換えたときは、下記のようにしてリロードすれば変更が反映される。

*Main> :l app/Main.hs
[1 of 1] Compiling Main             ( app/Main.hs, interpreted )
Ok, modules loaded: Main.

また、下記のようにしてコマンドラインパラメータ付きでmain関数を評価することもできる。この場合はWebサーバが実際に起動する。

*Main> :main 0.0.0.0 9999

ここで、Main.hs 内の関数を見てみよう。

main は Haskell のプログラムのエントリポイントとなる関数であり、プロセス起動時に最初に評価される。ここでは、コマンドラインパラメータからWebサーバの待ち受けIPアドレスとポート番号を取得して、warp を起動している。HTTPリクエスト発生時に評価される関数には routerApp が指定されている。

main :: IO ()
main = do
  host:port:_ <- getArgs
  Warp.runSettings (
    Warp.setHost (fromString host) $
    Warp.setPort (read port) $
    Warp.defaultSettings
    ) $ routerApp

routerApp ではリクエストされたURLを元に評価する関数を振り分けている。/posixtime がリクエストされれば dateAppが、それ以外がリクエストされれば staticApp が評価される。

routerApp :: Wai.Application
routerApp req respond
  | (["posixtime"] == path) = dateApp   req respond
  | otherwise               = staticApp req respond -- static html/js/css files
  where
    path = Wai.pathInfo req

dateApp は リクエスト毎にその時点でのサーバーの時刻をレスポンスとして返している。Int型で得られるUNIX時間をレスポンスとして返すため、Int => String => Text => ByteString(strict) => ByteString(lazy) の変換が行われている。

dateApp :: Wai.Application
dateApp req respond = do
  pt_milliseconds <- getPOSIXTime'
  let pt_lbs = LBS.fromStrict $ encodeUtf8 $ T.pack $ show $ pt_milliseconds
  respond $ Wai.responseLBS H.status200 [("Content-Type","text/plain")] pt_lbs

staticApp は main.html や main.js を レスポンスとして返すための、通常のWebファイルサーバである。ここでは、staticディレクトリ以下のファイルを処理対象としている。

staticApp :: Wai.Application
staticApp = Static.staticApp $ settings { Static.ssIndices = indices }
  where
    settings = Static.defaultWebAppSettings "static"
    indices = fromJust $ toPieces ["main.html"] -- default content

通常のWebファイルサーバであるため、Webアプリケーション動作中はコンパイルや再起動を行わなくても main.html や main.js を編集すれば次回リクエスト時に変更が反映される。

5. runghc を使用した動作確認

REPLに入らずに動作確認したいときは、下記のようにしてmain関数を評価することもできる。Haskellでは、スクリプト的な使い方も可能となっているのである。

$ stack runghc app/Main.hs 0.0.0.0 9999

6. ghc を使用した実行形式バイナリのビルド

下記のコマンドで実行形式バイナリがビルド(コンパイル)され、

$ stack build

下記のコマンドでインストールされ

$ stack install

~/.local/bin/wai-example-exe が生成される。実行形式バイナリの動作確認は下記のようにして行うことができるだろう。

 $ ~/.local/bin/wai-example-exe 0.0.0.0 9999

wai(Webアプリケーションライブラリ)やwarp(Webサーバ)を含むすべてのライブラリがwai-example-exeに静的にリンクされるため、wai-example-exe と staticディレクトリ を ビルド環境と同一アーキテクチャ、同一OSのマシンにコピーすればそのまま動作する。

この時、カレントディレクトリ配下の static ディレクトリ内のファイルが静的Webコンテンツとして参照されるが、ビルド時に settings を下記のように書き換えると、staticディレクトリ内のファイルを実行形式バイナリにすべて埋め込むことができる。静的Webコンテンツも含め、Webアプリケーションを一つのファイルにまとめることができるので、場合によってはとても便利である。

staticApp :: Wai.Application
staticApp = Static.staticApp $ settings { Static.ssIndices = indices }
  where
    settings = Static.embeddedSettings $(embedDir "static")
    indices = fromJust $ toPieces ["main.html"] -- default content

7. まとめ

  • Haskell の 環境構築は stack を使えば超簡単。
  • 一つのソースコードをまったく書き換えることなく REPL、スクリプト、実行形式バイナリの三態から利用可能。
  • WebアプリケーションとWebサーバが一体のため、実行形式バイナリをフロントエンドエンジニア や Webデザイナー に渡せばそのまま開発環境として使ってもらえる。
  • 実行形式バイナリでデプロイすれば、本番に必要な依存環境を最小化できるため、Vagrant や Docker などの環境構築ツールに頼らなくてよい。
  • 静的Webコンテンツを実行形式バイナリに埋め込めば、より安全確実なバージョン管理とデプロイが可能に。

8. おまけ

筆者の利用実績はないが、IDE とか欲しい人向けの情報。

  • Leksah -- Haskell で作られた Haskell用 IDE。
  • Haskell for Mac -- Mac向け。本格的な開発ができるかは不明だけど楽しそう。
  • haskell-idea-plugin -- IntelliJ用 のプラグイン。

Eitherモナドの使い道 部分的な失敗を全体的な失敗とする計算(2)

※この記事のMaybe編はこちら

idと名前のデータベースと、順位とidのデータベースからなる、下記のようなフレームワークを考えてみよう。

2位の名前を取り出すには、idFromRank で 2位のidを取り出し、その id を nameFromId に渡して名前を得るものとする。
idFromRank も nameFromId も要求された順位やidのデータがなければ Left に評価されるものとする。


type Err = String
type ID = Int
type Rank = Int
type Name = String
type RankDB = [(Rank,ID)]
type NameDB = [(ID,Name)]

idFromRank :: RankDB -> Rank -> Either Err ID
idFromRank db rk =
  case lookup rk db of
    Nothing -> Left $ "id of rank " ++ (show rk) ++ " was not found."
    Just id -> Right id

nameFromId :: NameDB -> ID -> Either Err Name
nameFromId db id =
  case lookup id db of
    Nothing   -> Left $ "name of id " ++ (show id) ++ " was not found."
    Just name -> Right name

このフレームワークを使って、上位3位の名前を取得する関数を作成してみよう。
ポイントは、idFromRank も nameFromId も Left に評価されることがあるため、この関数もEither型に評価されるものとし、1位から3位までのidがすべて存在し、それらの名前がすべて存在する場合のみRightに評価され、それ以外のときはLeftに評価されるようにすることだ。

下記のように呼び出されるようになればよいだろう。

main = do
  print $ topThree [(1,101),(2,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThree [(1,101),(4,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThree [(1,101),(2,102),(3,103)] [(101,"1st"),(104,"4th"),(103,"3rd")]

式を使ったプログラミングで素直に記述する場合、筆者の能力では下記の記述が限界である。
これはどう考えても地獄である。我々が関数プログラミングに求めていたものはこんなものではなかったはずだ。

topThree :: RankDB -> NameDB -> Either Err (Name,Name,Name)
topThree rdb ndb =
  let eitherId1 = idFromRank rdb 1
  in
   if isLeft eitherId1 then Left $ fromLeft eitherId1
   else
     let eitherName1 = nameFromId ndb $ fromRight eitherId1
     in
      if isLeft eitherName1 then Left $ fromLeft eitherName1
      else
        let eitherId2 = idFromRank rdb 2
        in
         if isLeft eitherId2 then Left $ fromLeft eitherId2
         else
           let eitherName2 = nameFromId ndb $ fromRight eitherId2
           in
            if isLeft eitherName2 then Left $ fromLeft eitherName2
            else
              let eitherId3 = idFromRank rdb 3
              in
               if isLeft eitherId3 then Left $ fromLeft eitherId3
               else
                 let eitherName3 = nameFromId ndb $ fromRight eitherId3
                 in
                  if isLeft eitherName3 then Left $ fromLeft eitherName3
                  else Right (
                    fromRight eitherName1,
                    fromRight eitherName2,
                    fromRight eitherName3
                    )
  where
    fromLeft (Left x) = x 
    fromRight (Right x) = x

Haskell には case 文があるので、効果的に使えば下記のように改善することができる。
しかし case 文の入れ子も本質的には地獄である。こんなことなら手続き型言語を使えばよいのではないか。

topThreeC :: RankDB -> NameDB -> Either Err (Name,Name,Name)
topThreeC rdb ndb =
  case idFromRank rdb 1 of
    Left e -> Left e
    Right id1 -> case nameFromId ndb id1 of
      Left e -> Left e
      Right n1 -> case idFromRank rdb 2 of
        Left e -> Left e
        Right id2 -> case nameFromId ndb id2 of
          Left e -> Left e
          Right n2 -> case idFromRank rdb 3 of
            Left e -> Left e
            Right id3 -> case nameFromId ndb id3 of
              Left e -> Left e
              Right n3 -> Right (n1,n2,n3)

そこで Eitherモナド登場。
Either型のモナドとしての性質を使うと、上記とまったく同じ意味の関数を下記の内容だけで記述することができる。
モナドとしてのEither型には、失敗するかもしれない計算どうしを組み合わせるときは、一部でも失敗したらすべてが失敗したことにする
という性質が最初から組み込まれているためである。

topThreeM :: RankDB -> NameDB -> Either Err (Name,Name,Name)
topThreeM rdb ndb = do

  id <- idFromRank rdb 1
  n1 <- nameFromId ndb id

  id <- idFromRank rdb 2
  n2 <- nameFromId ndb id
    
  id <- idFromRank rdb 3
  n3 <- nameFromId ndb id

  return (n1,n2,n3)

全部のせておく。

import Data.Either (isLeft)

type Err = String
type ID = Int
type Rank = Int
type Name = String
type RankDB = [(Rank,ID)]
type NameDB = [(ID,Name)]

idFromRank :: RankDB -> Rank -> Either Err ID
idFromRank db rk =
  case lookup rk db of
    Nothing -> Left $ "id of rank " ++ (show rk) ++ " was not found."
    Just id -> Right id

nameFromId :: NameDB -> ID -> Either Err Name
nameFromId db id =
  case lookup id db of
    Nothing   -> Left $ "name of id " ++ (show id) ++ " was not found."
    Just name -> Right name




topThree :: RankDB -> NameDB -> Either Err (Name,Name,Name)
topThree rdb ndb =
  let eitherId1 = idFromRank rdb 1
  in
   if isLeft eitherId1 then Left $ fromLeft eitherId1
   else
     let eitherName1 = nameFromId ndb $ fromRight eitherId1
     in
      if isLeft eitherName1 then Left $ fromLeft eitherName1
      else
        let eitherId2 = idFromRank rdb 2
        in
         if isLeft eitherId2 then Left $ fromLeft eitherId2
         else
           let eitherName2 = nameFromId ndb $ fromRight eitherId2
           in
            if isLeft eitherName2 then Left $ fromLeft eitherName2
            else
              let eitherId3 = idFromRank rdb 3
              in
               if isLeft eitherId3 then Left $ fromLeft eitherId3
               else
                 let eitherName3 = nameFromId ndb $ fromRight eitherId3
                 in
                  if isLeft eitherName3 then Left $ fromLeft eitherName3
                  else Right (
                    fromRight eitherName1,
                    fromRight eitherName2,
                    fromRight eitherName3
                    )
  where
    fromLeft (Left x) = x 
    fromRight (Right x) = x



topThreeC :: RankDB -> NameDB -> Either Err (Name,Name,Name)
topThreeC rdb ndb =
  case idFromRank rdb 1 of
    Left e -> Left e
    Right id1 -> case nameFromId ndb id1 of
      Left e -> Left e
      Right n1 -> case idFromRank rdb 2 of
        Left e -> Left e
        Right id2 -> case nameFromId ndb id2 of
          Left e -> Left e
          Right n2 -> case idFromRank rdb 3 of
            Left e -> Left e
            Right id3 -> case nameFromId ndb id3 of
              Left e -> Left e
              Right n3 -> Right (n1,n2,n3)



topThreeM :: RankDB -> NameDB -> Either Err (Name,Name,Name)
topThreeM rdb ndb = do

  id <- idFromRank rdb 1
  n1 <- nameFromId ndb id

  id <- idFromRank rdb 2
  n2 <- nameFromId ndb id
    
  id <- idFromRank rdb 3
  n3 <- nameFromId ndb id

  return (n1,n2,n3)




main = do
  print $ topThree [(1,101),(2,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThree [(1,101),(4,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThree [(1,101),(2,102),(3,103)] [(101,"1st"),(104,"4th"),(103,"3rd")]
  print $ topThreeC [(1,101),(2,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThreeC [(1,101),(4,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThreeC [(1,101),(2,102),(3,103)] [(101,"1st"),(104,"4th"),(103,"3rd")]
  print $ topThreeM [(1,101),(2,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThreeM [(1,101),(4,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThreeM [(1,101),(2,102),(3,103)] [(101,"1st"),(104,"4th"),(103,"3rd")]

Maybeモナドの使い道 部分的な失敗を全体的な失敗とする計算(1)

※この記事のEither編はこちら

idと名前のデータベースと、順位とidのデータベースからなる、下記のようなフレームワークを考えてみよう。

2位の名前を取り出すには、idFromRank で 2位のidを取り出し、その id を nameFromId に渡して名前を得るものとする。
idFromRank も nameFromId も要求された順位やidのデータがなければ Nothing に評価されるものとする。

type ID = Int
type Rank = Int
type Name = String
type RankDB = [(Rank,ID)]
type NameDB = [(ID,Name)]

idFromRank :: RankDB -> Rank -> Maybe ID
idFromRank db rk = lookup rk db

nameFromId :: NameDB -> ID -> Maybe Name
nameFromId db id = lookup id db

このフレームワークを使って、上位3位の名前を取得する関数を作成してみよう。
ポイントは、idFromRank も nameFromId も Nothing に評価されることがあるため、この関数もMaybe型に評価されるものとし、1位から3位までのidがすべて存在し、それらの名前がすべて存在する場合のみJustに評価され、それ以外のときはNothingに評価されるようにすることだ。

下記のように呼び出されるようになればよいだろう。

main = do
  print $ topThree [(1,101),(2,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThree [(1,101),(4,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThree [(1,101),(2,102),(3,103)] [(101,"1st"),(104,"4th"),(103,"3rd")]

式を使ったプログラミングで素直に記述する場合、筆者の能力では下記の記述が限界である。
これはどう考えても地獄である。我々が関数プログラミングに求めていたものはこんなものではなかったはずだ。

topThree :: RankDB -> NameDB -> Maybe (Name,Name,Name)
topThree rdb ndb =
  let maybeId1 = idFromRank rdb 1
  in
   if isNothing maybeId1 then Nothing
   else
     let maybeName1 = nameFromId ndb $ fromJust maybeId1
     in
      if isNothing maybeName1 then Nothing
      else
        let maybeId2 = idFromRank rdb 2
        in
         if isNothing maybeId2 then Nothing
         else
           let maybeName2 = nameFromId ndb $ fromJust maybeId2
           in
            if isNothing maybeName2 then Nothing
            else
              let maybeId3 = idFromRank rdb 3
              in
               if isNothing maybeId3 then Nothing
               else
                 let maybeName3 = nameFromId ndb $ fromJust maybeId3
                 in
                  if isNothing maybeName3 then Nothing
                  else Just (
                    fromJust maybeName1,
                    fromJust maybeName2,
                    fromJust maybeName3
                    )

Haskell には case 文があるので、効果的に使えば下記のように改善することができる。
しかし case 文の入れ子も本質的には地獄である。こんなことなら手続き型言語を使えばよいのではないか。

topThreeC :: RankDB -> NameDB -> Maybe (Name,Name,Name)
topThreeC rdb ndb =
  case idFromRank rdb 1 of
    Nothing -> Nothing
    Just id1 -> case nameFromId ndb id1 of
      Nothing -> Nothing
      Just n1 -> case idFromRank rdb 2 of
        Nothing -> Nothing
        Just id2 -> case nameFromId ndb id2 of
          Nothing -> Nothing
          Just n2 -> case idFromRank rdb 3 of
            Nothing -> Nothing
            Just id3 -> case nameFromId ndb id3 of
              Nothing -> Nothing
              Just n3 -> Just (n1,n2,n3)


そこで Maybeモナド登場。
Maybe型のモナドとしての性質を使うと、上記とまったく同じ意味の関数を下記の内容だけで記述することができる。
モナドとしてのMaybe型には、失敗するかもしれない計算どうしを組み合わせるときは、一部でも失敗したらすべてが失敗したことにする
という性質が最初から組み込まれているためである。

topThreeM :: RankDB -> NameDB -> Maybe (Name,Name,Name)
topThreeM rdb ndb = do

  id <- idFromRank rdb 1
  n1 <- nameFromId ndb id

  id <- idFromRank rdb 2
  n2 <- nameFromId ndb id
    
  id <- idFromRank rdb 3
  n3 <- nameFromId ndb id

  return (n1,n2,n3)

全部のせておく。

import Data.Maybe (isNothing,fromJust)

type ID = Int
type Rank = Int
type Name = String
type RankDB = [(Rank,ID)]
type NameDB = [(ID,Name)]

idFromRank :: RankDB -> Rank -> Maybe ID
idFromRank db rk = lookup rk db

nameFromId :: NameDB -> ID -> Maybe Name
nameFromId db id = lookup id db




topThree :: RankDB -> NameDB -> Maybe (Name,Name,Name)
topThree rdb ndb =
  let maybeId1 = idFromRank rdb 1
  in
   if isNothing maybeId1 then Nothing
   else
     let maybeName1 = nameFromId ndb $ fromJust maybeId1
     in
      if isNothing maybeName1 then Nothing
      else
        let maybeId2 = idFromRank rdb 2
        in
         if isNothing maybeId2 then Nothing
         else
           let maybeName2 = nameFromId ndb $ fromJust maybeId2
           in
            if isNothing maybeName2 then Nothing
            else
              let maybeId3 = idFromRank rdb 3
              in
               if isNothing maybeId3 then Nothing
               else
                 let maybeName3 = nameFromId ndb $ fromJust maybeId3
                 in
                  if isNothing maybeName3 then Nothing
                  else Just (
                    fromJust maybeName1,
                    fromJust maybeName2,
                    fromJust maybeName3
                    )
                                   


topThreeC :: RankDB -> NameDB -> Maybe (Name,Name,Name)
topThreeC rdb ndb =
  case idFromRank rdb 1 of
    Nothing -> Nothing
    Just id1 -> case nameFromId ndb id1 of
      Nothing -> Nothing
      Just n1 -> case idFromRank rdb 2 of
        Nothing -> Nothing
        Just id2 -> case nameFromId ndb id2 of
          Nothing -> Nothing
          Just n2 -> case idFromRank rdb 3 of
            Nothing -> Nothing
            Just id3 -> case nameFromId ndb id3 of
              Nothing -> Nothing
              Just n3 -> Just (n1,n2,n3)



topThreeM :: RankDB -> NameDB -> Maybe (Name,Name,Name)
topThreeM rdb ndb = do

  id <- idFromRank rdb 1
  n1 <- nameFromId ndb id

  id <- idFromRank rdb 2
  n2 <- nameFromId ndb id
    
  id <- idFromRank rdb 3
  n3 <- nameFromId ndb id

  return (n1,n2,n3)




main = do
  print $ topThree [(1,101),(2,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThree [(1,101),(4,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThree [(1,101),(2,102),(3,103)] [(101,"1st"),(104,"4th"),(103,"3rd")]
  print $ topThreeC [(1,101),(2,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThreeC [(1,101),(4,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThreeC [(1,101),(2,102),(3,103)] [(101,"1st"),(104,"4th"),(103,"3rd")]
  print $ topThreeM [(1,101),(2,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThreeM [(1,101),(4,102),(3,103)] [(101,"1st"),(102,"2nd"),(103,"3rd")]
  print $ topThreeM [(1,101),(2,102),(3,103)] [(101,"1st"),(104,"4th"),(103,"3rd")]



Readerモナドの使い道 仮想グローバル変数

現実的かどうかはさておき、税込み価格の商品と税抜き価格の商品が混在している店を考えてみよう。
会計の都合上、購入金額の合計を計算するときは、一旦すべての単価を税抜きに揃えてから集計し、まとめて税額を計算する必要があるものとする。

合計を計算するコードは下記のようになりそうだ。
このコードを眺めていると、toTaxIncluded と fromTaxIncluded の 引数 taxRate を消したくなってくるだろう。
ほぼ定数のようなものであり、合計の計算とは本質的に関係のない要素であるためだ。

main = do
  print $ total  0.08 [(108,True,2),(200,False,1),(324,True,2),(400,False,1)]


toTaxIncluded :: Float -> Float -> Float
toTaxIncluded taxRate price = price * (1.00 + taxRate)

fromTaxIncluded :: Float -> Float -> Float
fromTaxIncluded taxRate tiPrice = tiPrice / (1.00 + taxRate)

total :: Float -> [(Float,Bool,Int)] -> Float
total taxRate xs =
  let subTotal = foldl' step 0.0 xs
  in toTaxIncluded taxRate subTotal
  where
    step acc (price,taxin,quan) = acc + (unitPrice taxin price) * (fromIntegral quan)
    unitPrice taxin = if taxin
                      then fromTaxIncluded taxRate
                      else id


そこでコードを下記のように改善してみよう。taxRate が引数から消えてすっきりした。
Haskell のコードをスクリプトとして使用している場合はこれで十分だろう。
ただ、一旦コンパイルされてしまうと、toTaxIncludedG と fromTaxIncludedG が使用する税率は固定されてしまう。

main = do
  print $ totalG      [(108,True,2),(200,False,1),(324,True,2),(400,False,1)]


taxRateG :: Float
taxRateG = 0.08

toTaxIncludedG :: Float -> Float
toTaxIncludedG price = price * (1.00 + taxRateG)

fromTaxIncludedG :: Float -> Float
fromTaxIncludedG tiPrice = tiPrice / (1.00 + taxRateG)

totalG :: [(Float,Bool,Int)] -> Float
totalG xs =
  let subTotal = foldl' step 0.0 xs
  in toTaxIncludedG subTotal
  where
    step acc (price,taxin,quan) = acc + (unitPrice taxin price) * (fromIntegral quan)
    unitPrice taxin = if taxin
                      then fromTaxIncludedG
                      else id


そこでReaderモナド登場。Readerモナドを使用すると、手続き型プログラミングでグローバル変数として保持したいような要素を、自然に保持することができる。
runReader関数 の 第2引数で指定した値を、モナド内の任意の関数内で ask 関数を使用して取り出すことができる。

main = do
  print $ totalR 0.08 [(108,True,2),(200,False,1),(324,True,2),(400,False,1)]



toTaxIncludedR :: Float -> Reader Float Float
toTaxIncludedR price = do
  taxRate <- ask
  return $ price * (1.00 + taxRate)

fromTaxIncludedR :: Float -> Reader Float Float
fromTaxIncludedR tiPrice = do
  taxRate <- ask
  return $ tiPrice / (1.00 + taxRate)
  
totalR :: Float -> [(Float,Bool,Int)] -> Float
totalR taxRate xs = (`runReader` taxRate) $ do
  subTotal <- foldM step 0.0 xs
  toTaxIncludedR subTotal
  where
    step :: Float -> (Float,Bool,Int) -> Reader Float Float
    step acc (price,taxin,quan) = do
      up <- unitPrice taxin price
      return $ acc + up * (fromIntegral quan)
  
    unitPrice taxin = if taxin
                      then fromTaxIncludedR
                      else return


全部のせておく。

import Data.List (foldl')
import Control.Monad.Reader (Reader,runReader,ask)
import Control.Monad (foldM)


main = do
  print $ total  0.08 [(108,True,2),(200,False,1),(324,True,2),(400,False,1)]
  print $ totalG      [(108,True,2),(200,False,1),(324,True,2),(400,False,1)]
  print $ totalR 0.08 [(108,True,2),(200,False,1),(324,True,2),(400,False,1)]



toTaxIncluded :: Float -> Float -> Float
toTaxIncluded taxRate price = price * (1.00 + taxRate)

fromTaxIncluded :: Float -> Float -> Float
fromTaxIncluded taxRate tiPrice = tiPrice / (1.00 + taxRate)

total :: Float -> [(Float,Bool,Int)] -> Float
total taxRate xs =
  let subTotal = foldl' step 0.0 xs
  in toTaxIncluded taxRate subTotal
  where
    step acc (price,taxin,quan) = acc + (unitPrice taxin price) * (fromIntegral quan)
    unitPrice taxin = if taxin
                      then fromTaxIncluded taxRate
                      else id



taxRateG :: Float
taxRateG = 0.08

toTaxIncludedG :: Float -> Float
toTaxIncludedG price = price * (1.00 + taxRateG)

fromTaxIncludedG :: Float -> Float
fromTaxIncludedG tiPrice = tiPrice / (1.00 + taxRateG)

totalG :: [(Float,Bool,Int)] -> Float
totalG xs =
  let subTotal = foldl' step 0.0 xs
  in toTaxIncludedG subTotal
  where
    step acc (price,taxin,quan) = acc + (unitPrice taxin price) * (fromIntegral quan)
    unitPrice taxin = if taxin
                      then fromTaxIncludedG
                      else id



toTaxIncludedR :: Float -> Reader Float Float
toTaxIncludedR price = do
  taxRate <- ask
  return $ price * (1.00 + taxRate)

fromTaxIncludedR :: Float -> Reader Float Float
fromTaxIncludedR tiPrice = do
  taxRate <- ask
  return $ tiPrice / (1.00 + taxRate)
  
totalR :: Float -> [(Float,Bool,Int)] -> Float
totalR taxRate xs = (`runReader` taxRate) $ do
  subTotal <- foldM step 0.0 xs
  toTaxIncludedR subTotal
  where
    step :: Float -> (Float,Bool,Int) -> Reader Float Float
    step acc (price,taxin,quan) = do
      up <- unitPrice taxin price
      return $ acc + up * (fromIntegral quan)
  
    unitPrice taxin = if taxin
                      then fromTaxIncludedR
                      else return