diff --git a/yesod-websockets/chat-with-multiple-channels.hs b/yesod-websockets/chat-with-multiple-channels.hs new file mode 100644 index 00000000..8704d6f9 --- /dev/null +++ b/yesod-websockets/chat-with-multiple-channels.hs @@ -0,0 +1,122 @@ +{-# 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| +