Socket Example / Haskell

Haskellを使ったネットワークプログラムをテストしてみました。サーバ・クライアント通信で、クライアントから演算リクエストをサーバで実行して結果を返すというものです。Haskellのプログラムを小さな単位で重たい処理を分散実行できる点が面白いと思っています。

参考 : http://codereview.stackexchange.com/questions/8828/simple-tcp-client-memory-issues (クライアント)
http://www.catonmat.net/blog/simple-haskell-tcp-server/　(サーバ)

環境 : ghc 7.6.3 / Mac OSX 10.10.5

client.hs

import Control.Concurrent
import Network
import System.Environment
import System.IO

main :: IO ()
main = do
    [host, port] <- getArgs
    h <- connectTo host $ PortNumber $ toEnum $ read port
    hSetBuffering stdout LineBuffering
    hSetBuffering h      LineBuffering
    _ <- forkIO $ hGetContents h >>= putStr
    getContents >>= hPutStr h

import Control.Concurrent

import Network

import System.Environment

import System.IO

main :: IO ()

main = do

[host, port] <- getArgs

h <- connectTo host $ PortNumber $ toEnum $ read port

hSetBuffering stdout LineBuffering

hSetBuffering h LineBuffering

_ <- forkIO $ hGetContents h >>= putStr

getContents >>= hPutStr h

server.hs

import Network (listenOn, withSocketsDo, accept, PortID(..), Socket)
import System.Environment (getArgs)
import System.IO (hSetBuffering, hGetLine, hPutStrLn, BufferMode(..), Handle)
import Control.Concurrent (forkIO)

main :: IO ()
main = withSocketsDo $ do
    args <- getArgs
    let port = fromIntegral (read $ head args :: Int)
    sock <- listenOn $ PortNumber port
    putStrLn $ "Listening on " ++ (head args)
    sockHandler sock

sockHandler :: Socket -> IO ()
sockHandler sock = do
    (h, _, _) <- accept sock
    hSetBuffering h NoBuffering
    forkIO $ commandProcessor h
    sockHandler sock

commandProcessor :: Handle -> IO ()
commandProcessor h = do
    line <- hGetLine h
    putStrLn line
    let cmd = words line
    case (head cmd) of
        ("echo") -> echoCommand h cmd
        ("add") -> addCommand h cmd
        ("rev") -> revCommand h cmd
        ("fib") -> fibCommand h cmd
        ("fact") -> factCommand h cmd
        _ -> do hPutStrLn h "Unknown command"
    commandProcessor h

echoCommand :: Handle -> [String] -> IO ()
echoCommand h cmd = do
    hPutStrLn h (unwords $ tail cmd)

addCommand :: Handle -> [String] -> IO ()
addCommand h cmd = do
    hPutStrLn h $ show $ (read $ cmd !! 1) + (read $ cmd !! 2)

revCommand :: Handle -> [String] -> IO()
revCommand h cmd = do
    hPutStrLn h (reverse $ unwords $ tail cmd)

fibCommand :: Handle -> [String] -> IO()
fibCommand h cmd = do
    hPutStrLn h (show $ fib $ read $ cmd !! 1)

fib :: Integer -> Integer
fib 0 = 1
fib 1 = 1
fib n = fib (n-2) + fib (n- 1)

factCommand :: Handle -> [String] -> IO()
factCommand h cmd = do
    hPutStrLn h (show $ fact $ read $ cmd !! 1)

fact :: Integer -> Integer
fact 0 = 1
fact n = n * fact (n - 1)

import Network (listenOn, withSocketsDo, accept, PortID(..), Socket)

import System.Environment (getArgs)

import System.IO (hSetBuffering, hGetLine, hPutStrLn, BufferMode(..), Handle)

import Control.Concurrent (forkIO)

main :: IO ()

main = withSocketsDo $ do

args <- getArgs

let port = fromIntegral (read $ head args :: Int)

sock <- listenOn $ PortNumber port

putStrLn $ "Listening on " ++ (head args)

sockHandler sock

sockHandler :: Socket -> IO ()

sockHandler sock = do

(h, _, _) <- accept sock

hSetBuffering h NoBuffering

forkIO $ commandProcessor h

sockHandler sock

commandProcessor :: Handle -> IO ()

commandProcessor h = do

line <- hGetLine h

putStrLn line

let cmd = words line

case (head cmd) of

("echo") -> echoCommand h cmd

("add") -> addCommand h cmd

("rev") -> revCommand h cmd

("fib") -> fibCommand h cmd

("fact") -> factCommand h cmd

_ -> do hPutStrLn h "Unknown command"

commandProcessor h

echoCommand :: Handle -> [String] -> IO ()

echoCommand h cmd = do

hPutStrLn h (unwords $ tail cmd)

addCommand :: Handle -> [String] -> IO ()

addCommand h cmd = do

hPutStrLn h $ show $ (read $ cmd !! 1) + (read $ cmd !! 2)

revCommand :: Handle -> [String] -> IO()

revCommand h cmd = do

hPutStrLn h (reverse $ unwords $ tail cmd)

fibCommand :: Handle -> [String] -> IO()

fibCommand h cmd = do

hPutStrLn h (show $ fib $ read $ cmd !! 1)

fib :: Integer -> Integer

fib 0 = 1

fib 1 = 1

fib n = fib (n-2) + fib (n- 1)

factCommand :: Handle -> [String] -> IO()

factCommand h cmd = do

hPutStrLn h (show $ fact $ read $ cmd !! 1)

fact :: Integer -> Integer

fact 0 = 1

fact n = n * fact (n - 1)

コンパイル

ghc –make client.hs
ghc –make server.hs

Serverは、コマンドを増やしています。
Clientは、ファイルに記述したコマンドの連続実行もしました。

実行結果

Integerで任意精度演算(Arbitrary-precision, 自分はBignumの方が馴染みがありますが)が簡単にできるのは、便利です。