handles.hs

{- stack
  --resolver lts-4.2
  --install-ghc
  runghc
  --package network
-}
{-# LANGUAGE OverloadedStrings #-}
import Control.Concurrent.Async (concurrently)
import Control.Monad (forever)
import Network.Socket
import System.IO (Handle, IOMode(WriteMode), hClose)
import System.Environment (getArgs)
import System.Timeout (timeout)

import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL

main = do
    lazy <- elem "lazy" <$> getArgs
    if lazy
        then writeConcurrently BL.hPut lazyContent
        else writeConcurrently B.hPut strictContent


writeConcurrently :: (Handle -> b -> IO ()) -> (b, b) -> IO ()
writeConcurrently hPut (b, b') = do
    handle <- getHandle
    let writeForever = forever . hPut handle
    timeout 200000 $ concurrently (writeForever b) (writeForever b')
    hClose handle
  where
    getHandle = do
        sock <- socket AF_INET Stream defaultProtocol
        sockAddr <- SockAddrInet 8050 <$> inet_addr "127.0.0.1"
        connect sock sockAddr
        socketToHandle sock WriteMode


strictContent :: (B.ByteString, B.ByteString)
strictContent = ( "S" `B.append` "OM" `B.append` "E"
          , "TH" `B.append` "I" `B.append` "NG\n" )

lazyContent :: (BL.ByteString, BL.ByteString)
lazyContent = ( "S" `BL.append` "OM" `BL.append` "E"
          , "TH" `BL.append` "I" `BL.append` "NG\n" )