diff --git a/yesod-websockets/chat-with-timeout-control.hs b/yesod-websockets/chat-with-timeout-control.hs new file mode 100644 index 00000000..00df99fc --- /dev/null +++ b/yesod-websockets/chat-with-timeout-control.hs @@ -0,0 +1,106 @@ +{-# 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) + +data App = App (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 + App writeChan <- getYesod + 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| +