Two-way Chan

Chan2.hs

module Chan2 where

import Control.Concurrent

type Chan2 rq rs = Chan (rq, MVar rs)

call :: Chan2 rq rs -> rq -> IO rs
call chan rq = do
  mvar <- newEmptyMVar
  writeChan chan (rq, mvar)
  rs <- takeMVar mvar
  return rs

processCall :: Chan2 rq rs -> (rq -> IO (rs, x)) -> IO x
processCall chan handler = do
  (rq, mvar) <- readChan chan
  (rs, x) <- handler rq
  putMVar mvar rs
  return x

newChan2 :: IO (Chan2 rq rs)
newChan2 = newChan

test.hs

import Control.Concurrent
import System.IO

import Chan2

type Rq = String
type Rs = String

server :: Chan2 Rq Rs -> IO ()
server chan = do
  done <- processCall chan $ \rq ->
            if rq == "quit"
              then return ("ok", True)
              else return (rq ++ rq, False)
  if done
    then putStrLn "Server quit"
    else server chan

client :: Chan2 Rq Rs -> IO ()
client chan = do
  putStr "client> "
  rq <- getLine
  rs <- call chan rq
  putStrLn $ "server: " ++ rs
  if rq == "quit"
    then putStrLn "Client quit"
    else client chan

main :: IO ()
main = do
  hSetBuffering stdout NoBuffering
  chan <- newChan2
  forkIO $ server chan
  client chan
  return ()