HTMLのCanvasとHaskellでのWebSocketsを組み合わせる

Programming

前回、HTMLでCanvasを使用した描画を試しました。 今回は、HaskellでWebSocketsのサーバを作成し、当該サーバからバイナリデータを受信してCanvasに描画するようにしました。

まずは、ブラウザで動作させるファイルです。

<html>
    <body>
        <script
            src="https://code.jquery.com/jquery-3.2.1.js"
            integrity="sha256-DZAnKJ/6XZ9si04Hgrsxu/8s717jcIzLy3oi35EouyE="
            crossorigin="anonymous"></script>
        <p><div id="time">Time[ms]</div></p>
        <canvas id="canvas" width="1920" height="1080"></canvas>
        <script type="text/javascript">
            $(window).on('load', function(){
                var tm = 0;
                var canvas = $('#canvas').get(0);
                var width = canvas.width;
                var height = canvas.height;
                var ctx = canvas.getContext('2d');
                var imageData = ctx.getImageData(0, 0, width, height);

                var buf = new ArrayBuffer(imageData.data.length);
                var buf8 = new Uint8ClampedArray(buf);
                var data = new Uint32Array(buf);
                var start_ms = performance.now();
                var elapsed_ms;
                var cn = new WebSocket('ws://127.0.0.1:9160/');

                cn.addEventListener('message', function(ev){
                    var reader = new FileReader();
                    reader.addEventListener("loadend", function(){
                        var ary = new Uint8Array(reader.result);
                        //console.log(ary[0]);
                        for (var j = 0; j < height; j++){
                            for (var i = 0; i < width; i++){
                                var val = ary[j*width+i];
                                data[j*width+i] = (255<<24) | (val<<16) | (val<<8) | val;
                            }
                        }
                        imageData.data.set(buf8);
                        ctx.putImageData(imageData, 0, 0);
                        if (tm % 60 == 0){
                            var current = performance.now();
                            elapsed_ms = current - start_ms;
                            $("#time").text(elapsed_ms/60.0 + "[ms]");
                            start_ms = current;
                        }
                    });
                    reader.readAsArrayBuffer(ev.data);
                });

                var getData = function(){
                    var abuf = new ArrayBuffer(1);
                    var view = new Uint8Array(abuf);
                    view[0] = tm & 0xFF;
                    cn.send(abuf);
                    tm++;
                    setTimeout(getData, 1);
                }
                cn.addEventListener('open', function(){
                    getData();
                });
            });
        </script>
    </body>
</html>

上記のとおり、ローカルホストで動作するWebSocketサーバとの通信を開き、getData関数を繰り返し呼び出します。

getData関数では、1バイトの配列要素に、0-255で巡回する値を入れて、WebSocketサーバに送ります。

また、受信するmessageのイベントハンドラでは、ev.dataがJavaScriptのBlobなので、readAsArrayBufferでloadenedハンドラと結びつけます。 当該ハンドラでは、reader.resultがサーバから送られてきた生データの配列になります。これを前回の記事と同様、Canvasに描画します。

一方HaskellでのWebSocketsサーバは次コードです。

{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
module Main where

import Lib
import Data.Int
import Control.Exception (finally)
import Control.Monad (forever)
import qualified Data.Text as T
import qualified Data.Text.IO as T

import qualified Network.WebSockets as WS
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as L

main :: IO ()
main = WS.runServer "127.0.0.1" 9160 application

application :: WS.ServerApp
application pending = do
    conn <- WS.acceptRequest pending
    WS.forkPingThread conn 30
    forever $ do
        bytes <- WS.receiveData conn
        let seed:_ = L.unpack bytes
        let seed2 = fromIntegral (toInteger seed)
        WS.sendBinaryData conn (L.unfoldr (genData seed2) (0, 0))

genData (seed :: Int32) (j, i) =
    if j >= 1080 then Nothing
    else
        if i == 1919 then
            Just (fromIntegral (seed+i+j), (j+1, 0))
        else
            Just (fromIntegral (seed+i+j), (j, i+1))

何かデータを受信したら、先頭バイトを取り出し、Word8に変換して(fromIntegral . toIntegerの組み合わせ)、 unfoldrにgenData関数を渡して(初期値としてWord8を渡す)、ByteStringを生成させます。

genData関数がNothingを返すと、ByteStringの生成は終了されます。 Just (a, b)を返すと、aがByteStringの新しい要素となり、bがgenDataを再度呼び出すために用いられます。

結局、(0, 0)からスタートして、(1079, 1919)まで、(y座標, x座標)の組が引数として渡されるようにしています。

生成されたByteStringはsendBinaryData関数でクライアントに返されます。

WindowsにStackを使ってGHCや必要なライブラリをインストールし、サーバを動作させて、 Firefoxで同一マシンからアクセスしてみました。

…かなり遅い。前回はFirefoxのプロセスが30%程度CPUを消費していましたが、今回は15%未満でした。 その代わり、WebSocketsのサーバを動作させているコマンドプロンプトのプロセスが50%消費しています。 どうやらサーバ側が律速しているようです。

まだ詳細に調査していませんが、sendBinaryDataで単純にファイルの中身のようなデータを送る場合は、 もっと高速に動作している印象でした。そのことからすると、genDataの繰り返しが遅いのではないかと想像しています。

2017/12/20追記：ちょっと調べたところ、ByteStringはBuilderを使って生成したほうが速いらしいので、 Haskell側のプログラムを以下のように修正しました。

{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
module Main where

import Lib
import Data.Int
import Control.Exception (finally)
import Control.Monad (forM_, forever)
import qualified Data.Text as T
import qualified Data.Text.IO as T

import qualified Network.WebSockets as WS
import qualified Data.ByteString.Char8 as C
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Builder as B

main :: IO ()
main = WS.runServer "127.0.0.1" 9160 application

infixr 4 <>
(<>) = mappend

application :: WS.ServerApp
application pending = do
    conn <- WS.acceptRequest pending
    WS.forkPingThread conn 30
    forever $ do
        bytes <- WS.receiveData conn
        let seed:_ = L.unpack bytes
        let seed2 = fromIntegral (toInteger seed)
        WS.sendBinaryData conn (B.toLazyByteString (genData seed2 (0, 0)))

genData (seed :: Int32) (j, i) =
    if i == 1919 then
        if j == 1079 then
            B.word8 (fromIntegral (seed+i+j))
        else
            B.word8 (fromIntegral (seed+i+j)) <> genData seed (j+1, 0)
    else
        B.word8 (fromIntegral (seed+i+j)) <> genData seed (j, i+1)

大枠は同じですが、unfoldrの代わりに、toLazyByteStringを使用し、 genDataはword8を使用してBuilderを生成します。各画素のBuilderはmappend(<>)にて連結されます。

これで試してみたところ、Firefoxは30%程度まで負荷が上がったので、効率は多少上がったかもしれません。 それでも、まだHaskell側が50%消費しています。ごく単純なプログラムなので、これはいただけません。

仕組みの検証はできましたが、もう少し速くしたいところです。 今度はRustあたりで作成してみようかと検討しています。

2017/12/21追記：ByteStringあれこれを見ると、 Internalを使わないとパフォーマンスを出すのは難しそうですね。 mallocByteStringしてからscanrなどで置き換えていくのが良いのかもしれません。 また別途試してみたいと思います。

comments powered by Disqus

© 2019 東京に住むプログラマ (webmaster@living-in.tokyo). Based on MH Magazine lite.