ConduitベースのTCPサーバ・クライアント Ver 0.1

2016年10月22日現在の最新Conduitパッケージ群を使用したTCPサーバ・クライアントのセットを作ってみた。標準入力を送信し返答を標準出力するクライアントと、エコーサーバ。

Conduitは発展途上でたびたび仕様が変わっているので古い解説記事がまるで役に立たない。しばらくはこれが何かの参考になれば幸いです。

TCP Server Ver 0.1

Serverは比較的シンプル。永続的に動き続ける（接続が切れても次の接続を待つ）。

tcpserver.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}  -- converts String to ByteString implicitly
{-# LANGUAGE RankNTypes #-}

module Main where

import ClassyPrelude
import ClassyPrelude.Conduit
import Data.Conduit.Network
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as DBC
import Data.Conduit.Binary.Utils (trimC, snocC, traceC)  -- original: see below

main :: IO ()
main = runTCPServer settings $ \ad -> app (appSource ad) (appSink ad)

settings :: ServerSettings
settings = serverSettings 69 "*"

app :: Monad m => Producer m ByteString -> Consumer ByteString m () -> m ()
app source sink = source =$= trimC =$= traceC =$= checkQuitC "QUIT" =$= snocC '*' $$ sink

-- if the server recieves a quit code, disconnect the tcp connection
checkQuitC :: Monad m => ByteString -> Conduit ByteString m ByteString
checkQuitC code = do
  mbs <- await
  case mbs of
    Nothing -> return ()
    Just bs | DBC.isPrefixOf code bs -> yield code >> return ()
            | otherwise              -> yield bs >> checkQuitC code

TCP Client Ver 0.1

Client側は入力ソースがTCP ServerとStdinの二箇所あるため、一問一答形式にするためにconnect-and-resumeを用いる。

tcpclient.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}  -- converts String to ByteString implicitly
{-# LANGUAGE RankNTypes #-}

module Main where

import ClassyPrelude
import ClassyPrelude.Conduit
import Data.Conduit.Network
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as DBC
import Data.Conduit.Binary.Utils (trimC, snocC)  -- original: see below

main :: IO ()
main = runTCPClient settings $ \ad -> app (newResumableSource (appSource ad)) (appSink ad)

settings :: ClientSettings
settings = clientSettings 69 "127.0.0.1"

app :: MonadIO m => ResumableSource m ByteString -> Consumer ByteString m () -> m ()
app source sink = do
  stdinC =$= trimC $$ singleC =$= sink    -- consume 1 command
  (source', _) <- source $$++ singleC =$= snocC '\n' =$= stdoutC  -- consume 1 responce and resume
  app source' sink
  where
    singleC :: Monad m => Conduit a m a
    singleC = mapC id     -- consume 1 data (does not consume forever)

Common Functions

{-# LANGUAGE NoImplicitPrelude #-}

module Data.Conduit.Binary.Utils (
    snocC
  , trimC
  , traceC
  ) where

import ClassyPrelude
import ClassyPrelude.Conduit
import qualified Data.Char as DC
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as DBC

-- add a char at the last of ByteString
snocC :: Monad m => Char -> Conduit ByteString m ByteString
snocC c = mapC $ flip DBC.snoc c

-- trim left and right spaces of ByteString (for removing \n in the end of the commands from stdin)
trimC :: Monad m => Conduit ByteString m ByteString
trimC = mapC trim
  where
    trim :: ByteString -> ByteString
    trim = dropWhileEnd DC.isSpace . DBC.dropWhile DC.isSpace
    dropWhileEnd :: (Char -> Bool) -> ByteString -> ByteString
    dropWhileEnd f = fst . DBC.spanEnd f

-- trace in Conduit
traceC :: (Show i, Monad m) => Conduit i m i
traceC = mapC $ \i -> trace (show i) i

しかし、もう少し良いやり方があるような気がしますね。