Pipes chat server

PipeChat.hs

{-# LANGUAGE LambdaCase, DeriveGeneric, NamedFieldPuns, RecordWildCards, OverloadedStrings #-}
module Main where

import Pipes
import qualified Pipes.Prelude as P
import Pipes.Network.TCP
import qualified Data.ByteString as B
import qualified Data.HashTable.IO as H
import System.IO.Unsafe
import Data.Serialize
import GHC.Generics
import Control.Monad

import qualified Pipes.Concurrent as PC

type HashTable k v = H.BasicHashTable k v

type Username = B.ByteString

data Message =
  Message
  { recipient :: Username
  , content :: B.ByteString
  }
  deriving (Show, Generic, Eq)

instance Serialize Message

inboxes :: HashTable Username (PC.Output B.ByteString)
inboxes = unsafePerformIO H.new -- I won't tell if you won't

toInt :: Integral a => a -> Int
toInt = fromInteger . toInteger

decode' :: Serialize a => B.ByteString -> Maybe a
decode' = either (const Nothing) Just . decode

processMessagesFrom :: MonadIO m => B.ByteString -> Proxy () (Maybe Message) y' y m ()
processMessagesFrom user = forever $
  await >>= \case
    Nothing -> return ()
    Just (Message {..}) -> do
      liftIO $ H.lookup inboxes recipient >>= \case
        Nothing -> return ()
        Just output ->
          PC.atomically . void $ 
            PC.send output (user `B.append` " says: " `B.append` content)

main :: IO ()
main =
  serve (Host "127.0.0.1") "8000" $ \(connSock, _sockAddr) -> do
    recv connSock 1 >>= \case
      Nothing -> return ()
      Just x  -> do
        let nameLen = toInt (B.head x)
        recv connSock nameLen >>= \case
          Nothing       -> return ()
          Just username -> do
            (output, input) <- PC.spawn PC.Unbounded
            H.insert inboxes username output
            PC.forkIO . runEffect $
              fromSocket connSock 4096 >-> P.map decode' >-> processMessagesFrom username
            runEffect (PC.fromInput input >-> toSocket connSock)