{-# 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|
|] toWidget [lucius| \#output { width: 600px; height: 400px; border: 1px solid black; margin-bottom: 1em; p { margin: 0 0 0.5em 0; padding: 0 0 0.5em 0; border-bottom: 1px dashed #99aa99; } } \#input { width: 600px; display: block; } |] toWidget [julius| var url = document.URL, output = document.getElementById("output"), form = document.getElementById("form"), input = document.getElementById("input"), conn; url = url.replace("http:", "ws:").replace("https:", "wss:"); conn = new WebSocket(url); conn.onmessage = function(e) { var p = document.createElement("p"); p.appendChild(document.createTextNode(e.data)); output.appendChild(p); }; form.addEventListener("submit", function(e){ conn.send(input.value); input.value = ""; e.preventDefault(); }); |] main :: IO () main = do chan <- atomically newBroadcastTChan warp 3000 $ App chan