A Haskell Concurrency pattern for servers

concurrent.hs

{-# LANGUAGE LambdaCase #-}

import Control.Concurrent
import Control.Concurrent.Chan
import Control.Monad
import Network.Socket
import System.IO

data MainMessage = Accept Socket SockAddr
                 | MsgReceived String

acceptor listenSock chan = forever $ do
	(sock, addr) <- accept listenSock
	writeChan chan (Accept sock addr)

handler sock chan = forever $ do
	s <- hGetLine sock
	putStrLn $ "> " ++ s
	writeChan chan (MsgReceived s)
	hPutStrLn sock s

main = do
	putStrLn "initializing..."
	sock <- socket AF_INET Stream 0
	bindSocket sock (SockAddrInet 123 iNADDR_ANY)
	listen sock 8

	chan <- newChan :: IO (Chan MainMessage)
	forkIO (acceptor sock chan)

	putStrLn "running..."
	forever $ do
		readChan chan >>= \case
			Accept s addr -> do
				putStrLn $ "got new connection from " ++ show addr
				h <- socketToHandle s ReadWriteMode
				void $ forkIO (handler h chan)
			MsgReceived msg -> putStrLn $ "main: got msg: " ++ msg