{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-} 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 qualified Data.Map as M data App = App (TVar (M.Map Text (TChan Text))) instance Yesod App mkYesod "App" [parseRoutes| / HomeR GET |] chatApp :: WebSocketsT Handler () chatApp = do sendTextData ("Welcome to the chat server, please enter your name." :: Text) name <- receiveData sendTextData $ "Welcome, " <> name <> ". Please enter your channel ID" channelId <- receiveData sendTextData $ name <> " just joined " <> channelId App channelMapTVar <- getYesod channelMap <- readTVarIO channelMapTVar let maybeChan = M.lookup channelId channelMap writeChan <- atomically $ case maybeChan of Nothing -> do chan <- newBroadcastTChan writeTVar channelMapTVar $ M.insert channelId chan channelMap return chan Just writeChan -> return writeChan readChan <- atomically $ do writeTChan writeChan $ name <> " has joined the chat" dupTChan writeChan race_ (forever $ atomically (readTChan readChan) >>= sendTextData) (sourceWS $$ mapM_C (\msg -> atomically $ writeTChan writeChan $ name <> ": " <> msg)) getHomeR :: Handler Html getHomeR = do webSockets chatApp defaultLayout $ do [whamlet|