今日GithubのHaskellのトレンドを見ていたらjaspervdj/websocketsが上がっていました。ソケット通信といえばSocket.IOな昨今ですがHaskellにもsocket-ioというバインディングが存在します。しかし何度か使おうと思って挑戦したんですがまだまだレベルが低くて使い方がわからず…
今日見つけたwebsocketは例のコードも短く使いやすそうだったので勉強がてら簡単なチャットを作ってみました。
まず依存ライブラリをインストールします
$ cabal install websockets warp wai-websockets
インストールが終わるまでコーヒーでも飲んで待ちましょう☕
終わったら早速アプリを書いていきます！
chat.hs
{-# LANGUAGE OverloadedStrings #-}
import Control.Monad (forever)
import Control.Exception (finally)
import Data.IORef
import Data.Text (Text)
import Network.HTTP.Types (hContentType)
import Network.HTTP.Types.Status (status200)
import Network.Wai (Application, responseFile)
import Network.Wai.Handler.WebSockets (websocketsOr)
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.WebSockets as WS
type Client = (Int, WS.Connection)
broadcast :: Text -> [Client] -> IO ()
broadcast msg = mapM_ (flip WS.sendTextData msg) . map snd
addClient :: WS.Connection -> [Client] -> ([Client], Int)
addClient conn cs = let i = if null cs then 0 else maximum (map fst cs) + 1
in ((i, conn):cs, i)
removeClient :: Int -> [Client] -> ([Client], ())
removeClient i cs = (filter (\c -> fst c /= i) cs, ())
chat :: IORef [Client] -> WS.ServerApp
chat ref pending = do
conn <- WS.acceptRequest pending
identifier <- atomicModifyIORef ref (addClient conn)
flip finally (disconnect identifier) $ forever $ do
msg <- WS.receiveData conn
conns <- readIORef ref
broadcast msg conns
where
disconnect identifier = atomicModifyIORef ref (removeClient identifier)
app :: Application
app req respond = respond $ responseFile status200 [(hContentType, "text/html")] "index.html" Nothing
main :: IO ()
main = do
let port = 3000
let setting = Warp.setPort port Warp.defaultSettings
putStrLn $ "Your server is listening at http://localhost:" ++ show port ++ "/"
ref <- newIORef []
Warp.runSettings setting $ websocketsOr WS.defaultConnectionOptions (chat ref) app
ドーン！！と一気に全部のコードを載せましたが少しずつ解説していきますｗ
まずmain関数ですがdo以降の最初の３行はWebサーバーのポートなど基本設定を行っています。次のref <- newIORef []は接続してきたユーザーを管理するためのIORefを作っています。refの型はIORef [Client]です。Clientは上の方で
type Client = (Int, WS.Connection)
と定義されており、識別子とコネクションの組になっています。
Warp.runSettings setting $ websocketsOr WS.defaultConnectionOptions (chat ref) app
でいよいよサーバーを起動しています。websocketsOr :: ConnectionOptions -> ServerApp -> Application -> ApplicationはWebSocketサーバーとWebサーバーを同時に建てる時に使う関数でchat refがWebSocketサーバー、appがWebサーバーになっています。まずappを見てみましょう。
app :: Application
app req respond = respond $ responseFile status200 [(hContentType, "text/html")] "index.html" Nothing
これはどんなリクエストが来てもindex.htmlを返すだけのサーバーです。index.htmlは後で作っていきます。
chat :: IORef [Client] -> WS.ServerApp
chat ref pending = do
conn <- WS.acceptRequest pending
identifier <- atomicModifyIORef ref (addClient conn)
flip finally (disconnect identifier) $ forever $ do
msg <- WS.receiveData conn
conns <- readIORef ref
broadcast msg conns
where
disconnect identifier = atomicModifyIORef ref (removeClient identifier)
これがチャットサーバーの本体です。acceptRequest :: PendingConnection -> IO Connectionはクライアントからの接続を待つ関数で、クライアントが接続してきたらatomicModifyIORefを使って部屋情報のIORefにクライアントを登録しています。
addClient :: WS.Connection -> [Client] -> ([Client], Int)
addClient conn cs = let i = if null cs then 0 else maximum (map fst cs) + 1
in ((i, conn):cs, i)
addClientの実装はこのようになってて、識別子は最大値+1にしています。クライアントを登録したらflip finally (disconnect identifier)でユーザーが離脱した時に終了処理をすることを保証した後にforeverを使って受け取ったメッセージをひたすらブロードキャストしています。
broadcast :: Text -> [Client] -> IO ()
broadcast msg = mapM_ (flip WS.sendTextData msg) . map snd
ブロードキャストの関数は全てのクライアントにメッセージを送っているだけです。ユーザー離脱時の処理は
removeClient :: Int -> [Client] -> ([Client], ())
removeClient i cs = (filter (\c -> fst c /= i) cs, ())
このremoveClientをatomicModifyIORefで実行しています。
index.html
<!DOCTYPE>
<html>
<head>
<script src="//ajax.googleapis.com/ajax/libs/jquery/2.1.3/jquery.min.js"></script>
</head>
<body>
<form><input type="text"/></form>
<div></div>
<script>
try {
var ws = new WebSocket('ws://localhost:3000/');
} catch (err) {
console.error(err);
}
$("form").submit(function(){
ws.send($('input').val());
$('input').val('');
return false;
});
ws.onmessage = function (msg) {
$('div').prepend(msg.data + '<br>');
}
</script>
</body>
</html>
index.htmlはこんな感じです。さっそく実行してみましょう。
$ runhaskell chat.hs
別々にブラウザを開いてリアルタイムにチャットが出来てることが確認できました！
##参考にしたサイト