{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings, ScopedTypeVariables #-} import Yesod.Core import Yesod.WebSockets import qualified Data.Text.Lazy as TL import Control.Monad (forever) import Control.Monad.Trans.Reader import Control.Concurrent (threadDelay) import Data.Time import Conduit import Data.Monoid ((<>)) import Control.Concurrent.STM.Lifted import Data.Text (Text) import UnliftIO.Exception (try, SomeException) data App = App (TChan Text) mkYesod "App" [parseRoutes| / HomeR GET |] instance Yesod App chatApp :: WebSocketsT Handler () chatApp = do sendTextData ("Welcome to the chat server, please enter your name." :: Text) name <- receiveData sendTextData $ "Welcome, " <> name App writeChan <- getYesod readChan <- atomically $ do writeTChan writeChan $ name <> " has joined the chat" dupTChan writeChan (e :: Either SomeException ()) <- try $ race_ (forever $ atomically (readTChan readChan) >>= sendTextData) (sourceWS $$ mapM_C (\msg -> atomically $ writeTChan writeChan $ name <> ": " <> msg)) atomically $ case e of Left _ -> writeTChan writeChan $ name <> " has left the chat" Right () -> return () getHomeR :: Handler Html getHomeR = do webSockets chatApp defaultLayout $ do [whamlet|