haskellでチャットサーバーと1:1のペアリングする部分を実装した

書いたというかコピペした。 ゼロから書けるようになりたい。 例によって参考にさせていただいたページ

qiita.com

いつもお世話になっております。

↓こんな感じです

ソース

{-# LANGUAGE OverloadedStrings #-}
module Chat where

import Control.Monad (forever, forM_)
import Control.Exception (finally)
import Data.Maybe (isNothing, isJust)
import Data.IORef
import Data.Text (Text)
import qualified Data.Map as M
import Network.HTTP.Types (hContentType)
import Network.HTTP.Types.Status (status204)
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

-- Network-WebSockets
-- type ServerApp = PendingConnection -> IO ()
--

type ConnId = Int
type Client = (ConnId, WS.Connection)
type RoomPair = (Client, Maybe Client)

broadcast :: Text -> [Client] -> IO ()
broadcast msg = mapM_ $ (`WS.sendTextData` msg) . 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, ())

addRoomPair :: Client -> [RoomPair] -> ([RoomPair], RoomPair)
addRoomPair c rps = ((c, Nothing):rps, (c, Nothing))

modRoomPair :: Client -> [RoomPair] -> [RoomPair] -> ([RoomPair], RoomPair)
modRoomPair c (rx : rxs) rps =
    let
        roomPair = filter (isJust . snd) rps ++ rxs
    in
    ((fst rx, Just c):roomPair, (fst rx, Just c))

removeRoomPair :: Int -> [RoomPair] -> ([RoomPair], [RoomPair])
removeRoomPair i rps =
    let
        filterDisconnectPair rp =
            case rp of
                (cl1, Just cl2) -> fst cl1 /= i && fst cl2 /= i
                (cl1, _) -> fst cl1 /= i
        filterConnectPair rp =
            case rp of
                (cl1, Just cl2) -> fst cl1 == i || fst cl2 == i
                (cl1, _) -> fst cl1 == i
    in
    (filter filterDisconnectPair rps, filter filterConnectPair rps)

chat :: IORef [Client] -> IORef [RoomPair] -> WS.ServerApp
chat ref pairRef pendingConn = do

    conn <- WS.acceptRequest pendingConn
    identifier <- atomicModifyIORef ref (addClient conn)

    -- pairing
    let client = (identifier, conn)
    pairRooms <- readIORef pairRef
    rp <- case filter (isNothing . snd) pairRooms of
               x : xs -> atomicModifyIORef pairRef (modRoomPair client (x:xs))

               _ -> atomicModifyIORef pairRef (addRoomPair client)

    case rp of
      (cl1, Just cl2) -> broadcast "pairling" [cl1, cl2]
      (cl1, Nothing) -> broadcast "wait" [cl1]

    flip finally (bothDisconnect identifier) $ forever $ do
        msg <- WS.receiveData conn
        conns <- readIORef ref
        pairRooms <- readIORef pairRef
        let roomPair = filter (filterRoomPair identifier) pairRooms

        case roomPair of
          ((cl1, Just cl2):_) -> broadcast msg [cl1, cl2]
          _ -> putStrLn "no connect"
    where
    -- def function in where
    disconnect identifier = atomicModifyIORef ref (removeClient identifier)
    disconnectPair identifier = atomicModifyIORef pairRef (removeRoomPair identifier)
    bothDisconnect identifier = do
                            disconnect identifier
                            roomPair <- disconnectPair identifier
                            case roomPair of
                              ((cl1, Just cl2):_) -> broadcast "the other one is disconnected!" [cl1, cl2]
                              _ -> putStrLn "room pair is deleted"

filterRoomPair :: ConnId -> RoomPair -> Bool
filterRoomPair cid rp =
    case rp of
        (cl1, Just cl2) -> fst cl1 == cid || fst cl2 == cid
        _ -> False

app :: Application
app req respond = respond $ responseFile status204 [] "" Nothing

chatMain :: IO ()
chatMain = do
    let port = 3000
    let setting = Warp.setPort port Warp.defaultSettings
    putStrLn $ "Your server is listening at http://localhost:" ++ show port ++ "/"
    ref <- newIORef []
    pairRef <- newIORef []
    Warp.runSettings setting $ websocketsOr WS.defaultConnectionOptions (chat ref pairRef) app

単純に、type Client のタプルを用意して、それぞれのコネクションにメッセージを送るようにしただけです。 詳しい説明はリンク元に書いてあるので、以下、読んでて詰まったところのメモです。

type定義

chat :: IORef [Client] -> WS.ServerApp
chat ref pendingConn = do
...

• 型定義と引数の数が違うんだけど？ってなった
  • WS.ServerAppの定義が PendingConnection -> IO () みたい
  • IORef [Client] -> PendingConnection -> IO () ってことなんですね

部分適用的な

Warp.runSettings setting $ websocketsOr WS.defaultConnectionOptions (chat ref) app

• (chat ref) の部分、 pendingConn どこ行った？ってなりました
• 部分適用的な感じで(chat ref)として渡してるだけっぽいですね
• 定義は↓

websocketsOr :: ConnectionOptions -> ServerApp -> Application -> Application
defaultConnectionOptions :: ConnectionOptions
chat :: IORef [Client] -> ServerApp
  -- 引数込みだと => chat ref :: ServerApp
app :: Application

whereに関数定義

    where
    disconnect identifier = atomicModifyIORef ref (removeClient identifier)

• 左辺に変数２つあるけど何？ってなった
• よく考えたら普通に関数定義だった
• 型注釈無いと気づけ無い（雑魚）
• 言われてみれば当然な気がするけれど普通にwhereにも関数定義できるのか

flip, finally, forever

    flip finally (bothDisconnect identifier) $ forever $ do
...

• 摩訶不思議アドベンチャー
• それぞれの関数を整理する必要がありそう
• flip
  • 引数を逆にする、
  • 今回は読みやすさ的にflipしてるのかな？doもあるし
    • 見た目てきには完全にflipしてる方が見やすい

-- flip
flip finally (bothDisconnect identifier) $ forever $ do
    msg <- WS.receiveData conn
    conns <- readIORef ref
    pairRooms <- readIORef pairRef
    let roomPair = filter (filterRoomPair identifier) pairRooms
    case roomPair of
      ((cl1, Just cl2):_) -> broadcast msg [cl1, cl2]
      _ -> putStrLn "no connect"

-- no flip
finally (forever $ do
    msg <- WS.receiveData conn
    conns <- readIORef ref
    pairRooms <- readIORef pairRef
    let roomPair = filter (filterRoomPair identifier) pairRooms
    case roomPair of
      ((cl1, Just cl2):_) -> broadcast msg [cl1, cl2]
      _ -> putStrLn "no connect"
  ) (bothDisconnect identifier)

括弧は減らしたいしできれば$も減らしたい

• finally
  • 普通に例外処理の話だった
• forever
  • 無限ループっぽい動き
  • 接続が切れたらfinallyの中入る感じですかね
• matome
  • flip (finally) (bothDisconnect identifier) (forever (do Action)) な感じ
  • flipはfinallyに適用されていて、最終的に実行するのが (bothDisconnect identifier) の部分
  • finallyで最終的に接続断処理
  • forever のdoの中で接続処理

おわり

haskellでwebsocketサーバーを立てる試みをしてみました。 リアルタイムで動きがあるのは面白いけど、リアルタイムって人がいないとまともに稼働しないのが悲しいです。 九割九分コピペなので理解度が不安。 Wai, Warpをよく分かってないのもあまり良くないなあと思います。 servantも使ってみたいです。 言語問わず、少しかけるようになると自分が書ける範囲で大体のことをしてしまいがちなので、ちゃんと人のコード読むのは今更ながら良いなあとは思いました。 今回だとflipとかwhere内に関数定義とかまさにそんな感じで、なるほど便利、と思いました。 自分で書き足した部分が何となくスマートじゃない感じすこぶるあるけど、じゃあどうすればいい感じになるの？ってあたりがわからない。