diff --git a/yesod-websockets/Yesod/WebSockets.hs b/yesod-websockets/Yesod/WebSockets.hs index a08e644b..eebe9202 100644 --- a/yesod-websockets/Yesod/WebSockets.hs +++ b/yesod-websockets/Yesod/WebSockets.hs @@ -11,11 +11,18 @@ module Yesod.WebSockets , sourceWS , sinkWSText , sinkWSBinary + -- * Async helpers + , race + , race_ + , concurrently + , concurrently_ ) where -import Control.Monad (when, forever) +import qualified Control.Concurrent.Async as A +import Control.Monad (forever, void, when) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Trans.Control (control) +import Control.Monad.Trans.Control (MonadBaseControl (liftBaseWith, restoreM)) import Control.Monad.Trans.Reader (ReaderT (ReaderT, runReaderT)) import qualified Data.Conduit as C import qualified Data.Conduit.List as CL @@ -83,3 +90,35 @@ sinkWSText = CL.mapM_ sendTextData -- Since 0.1.0 sinkWSBinary :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) () sinkWSBinary = CL.mapM_ sendBinaryData + +-- | Generalized version of 'A.race'. +-- +-- Since 0.1.0 +race :: MonadBaseControl IO m => m a -> m b -> m (Either a b) +race x y = liftBaseWith (\run -> A.race (run x) (run y)) + >>= either (fmap Left . restoreM) (fmap Right . restoreM) + +-- | Generalized version of 'A.race_'. +-- +-- Since 0.1.0 +race_ :: MonadBaseControl IO m => m a -> m b -> m () +race_ x y = void $ race x y + +-- | Generalized version of 'A.concurrently'. Note that if your underlying +-- monad has some kind of mutable state, the state from the second action will +-- overwrite the state from the first. +-- +-- Since 0.1.0 +concurrently :: MonadBaseControl IO m => m a -> m b -> m (a, b) +concurrently x y = do + (resX, resY) <- liftBaseWith $ \run -> A.concurrently (run x) (run y) + x' <- restoreM resX + y' <- restoreM resY + return (x', y') + +-- | Run two actions concurrently (like 'A.concurrently'), but discard their +-- results and any modified monadic state. +-- +-- Since 0.1.0 +concurrently_ :: MonadBaseControl IO m => m a -> m b -> m () +concurrently_ x y = void $ liftBaseWith $ \run -> A.concurrently (run x) (run y) diff --git a/yesod-websockets/sample.hs b/yesod-websockets/sample.hs index 86e6630b..e369a99e 100644 --- a/yesod-websockets/sample.hs +++ b/yesod-websockets/sample.hs @@ -3,6 +3,10 @@ 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 data App = App @@ -12,11 +16,17 @@ mkYesod "App" [parseRoutes| / HomeR GET |] +timeSource :: MonadIO m => Source m TL.Text +timeSource = forever $ do + now <- liftIO getCurrentTime + yield $ TL.pack $ show now + liftIO $ threadDelay 5000000 + getHomeR :: Handler Html getHomeR = do - webSockets $ forever $ do - msg <- receiveData - sendTextData $ TL.toUpper msg + webSockets $ race_ + (sourceWS $$ mapC TL.toUpper =$ sinkWSText) + (timeSource $$ sinkWSText) defaultLayout $ toWidget [julius| diff --git a/yesod-websockets/yesod-websockets.cabal b/yesod-websockets/yesod-websockets.cabal index c47b8c86..49fb58b5 100644 --- a/yesod-websockets/yesod-websockets.cabal +++ b/yesod-websockets/yesod-websockets.cabal @@ -23,6 +23,7 @@ library , yesod-core >= 1.2.7 , monad-control >= 0.3 , conduit >= 1.0.15.1 + , async >= 2.0.1.5 source-repository head type: git