haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

More moving over to unliftio

Browse Source
This commit is contained in:
Michael Snoyman 2017-12-31 09:20:02 +02:00
parent eac95935e6
commit a16e75249a
No known key found for this signature in database
GPG Key ID: A048E8C057E86876
15 changed files with 39 additions and 224 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

89
yesod-auth/Yesod/Auth/GoogleEmail.hs
View File

@ -1,89 +0,0 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
-- | Use an email address as an identifier via Google's OpenID login system.
--
-- This backend will not use the OpenID identifier at all. It only uses OpenID
-- as a login system. By using this plugin, you are trusting Google to validate
-- an email address, and requiring users to have a Google account. On the plus
-- side, you get to use email addresses as the identifier, many users have
-- existing Google accounts, the login system has been long tested (as opposed
-- to BrowserID), and it requires no credential managing or setup (as opposed
-- to Email).
module Yesod.Auth.GoogleEmail
{-# DEPRECATED "Google no longer provides OpenID support, please use Yesod.Auth.GoogleEmail2" #-}
( authGoogleEmail
, forwardUrl
) where
import Yesod.Auth
import qualified Web.Authenticate.OpenId as OpenId
import Yesod.Core
import Data.Text (Text)
import qualified Yesod.Auth.Message as Msg
import qualified Data.Text as T
import Control.Exception.Lifted (try, SomeException)
pid :: Text
pid = "googleemail"
forwardUrl :: AuthRoute
forwardUrl = PluginR pid ["forward"]
googleIdent :: Text
googleIdent = "https://www.google.com/accounts/o8/id"
authGoogleEmail :: YesodAuth m => AuthPlugin m
authGoogleEmail =
AuthPlugin pid dispatch login
where
complete = PluginR pid ["complete"]
login tm =
[whamlet|<a href=@{tm forwardUrl}>_{Msg.LoginGoogle}|]
dispatch "GET" ["forward"] = do
render <- getUrlRender
let complete' = render complete
master <- lift getYesod
eres <- lift $ try $ OpenId.getForwardUrl googleIdent complete' Nothing
[ ("openid.ax.type.email", "http://schema.openid.net/contact/email")
, ("openid.ns.ax", "http://openid.net/srv/ax/1.0")
, ("openid.ns.ax.required", "email")
, ("openid.ax.mode", "fetch_request")
, ("openid.ax.required", "email")
, ("openid.ui.icon", "true")
] (authHttpManager master)
either
(\err -> do
tm <- getRouteToParent
lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException))
redirect
eres
dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues
dispatch "GET" ["complete"] = do
rr <- getRequest
completeHelper $ reqGetParams rr
dispatch "POST" ["complete", ""] = dispatch "POST" ["complete"] -- compatibility issues
dispatch "POST" ["complete"] = do
(posts, _) <- runRequestBody
completeHelper posts
dispatch _ _ = notFound
completeHelper :: [(Text, Text)] -> AuthHandler master TypedContent
completeHelper gets' = do
master <- lift getYesod
eres <- lift $ try $ OpenId.authenticateClaimed gets' (authHttpManager master)
tm <- getRouteToParent
either (onFailure tm) (onSuccess tm) eres
where
onFailure tm err =
lift $ loginErrorMessage (tm LoginR) $ T.pack $ show (err :: SomeException)
onSuccess tm oir = do
let OpenId.Identifier ident = OpenId.oirOpLocal oir
memail <- lookupGetParam "openid.ext1.value.email"
case (memail, "https://www.google.com/accounts/o8/id" `T.isPrefixOf` ident) of
(Just email, True) -> lift $ setCredsRedirect $ Creds pid email []
(_, False) -> lift $ loginErrorMessage (tm LoginR) "Only Google login is supported"
(Nothing, _) -> lift $ loginErrorMessage (tm LoginR) "No email address provided"

2
yesod-auth/Yesod/Auth/OpenId.hs
View File

@ -19,7 +19,7 @@ import Yesod.Form
import Yesod.Core
import Data.Text (Text, isPrefixOf)
import qualified Yesod.Auth.Message as Msg
import Control.Exception.Lifted (SomeException, try)
import UnliftIO.Exception (SomeException, try)
import Data.Maybe (fromMaybe)
import qualified Data.Text as T

3
yesod-auth/yesod-auth.cabal
View File

@ -43,7 +43,7 @@ library
, http-client
, http-conduit >= 2.1
, aeson >= 0.7
, lifted-base >= 0.1
, unliftio
, blaze-html >= 0.5
, blaze-markup >= 0.5.1
, http-types
@ -74,7 +74,6 @@ library
Yesod.Auth.OpenId
Yesod.Auth.Rpxnow
Yesod.Auth.Message
Yesod.Auth.GoogleEmail
Yesod.Auth.GoogleEmail2
Yesod.Auth.Hardcoded
Yesod.Auth.Util.PasswordStore

7
yesod-core/Yesod/Core.hs
View File

@ -95,8 +95,7 @@ module Yesod.Core
, module Text.Blaze.Html
, MonadTrans (..)
, MonadIO (..)
, MonadBase (..)
, MonadBaseControl
, MonadUnliftIO (..)
, MonadResource (..)
, MonadLogger
-- * Commonly referenced functions/datatypes
@ -143,9 +142,7 @@ import qualified Yesod.Core.Internal.Run
import qualified Paths_yesod_core
import Data.Version (showVersion)
import Yesod.Routes.Class
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Base (MonadBase (..))
import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO (..))
import Control.Monad.Trans.Resource (MonadResource (..))
import Yesod.Core.Internal.LiteApp

14
yesod-core/Yesod/Core/Class/Handler.hs
View File

@ -5,15 +5,14 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- Because of ErrorT
module Yesod.Core.Class.Handler
( MonadHandler (..)
, MonadWidget (..)
) where
import Yesod.Core.Types
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource (MonadResource, MonadResourceBase)
import Control.Monad.IO.Unlift (liftIO, MonadUnliftIO, MonadIO)
import Control.Monad.Trans.Resource (MonadResource)
import Control.Monad.Trans.Class (lift)
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid (Monoid)
@ -23,7 +22,6 @@ import Data.Conduit.Internal (Pipe, ConduitM)
import Control.Monad.Trans.Identity ( IdentityT)
import Control.Monad.Trans.List ( ListT )
import Control.Monad.Trans.Maybe ( MaybeT )
import Control.Monad.Trans.Error ( ErrorT, Error)
import Control.Monad.Trans.Except ( ExceptT )
import Control.Monad.Trans.Reader ( ReaderT )
import Control.Monad.Trans.State ( StateT )
@ -40,12 +38,12 @@ class MonadResource m => MonadHandler m where
replaceToParent :: HandlerData site route -> HandlerData site ()
replaceToParent hd = hd { handlerToParent = const () }
instance MonadResourceBase m => MonadHandler (HandlerT site m) where
instance MonadIO m => MonadHandler (HandlerT site m) where
type HandlerSite (HandlerT site m) = site
liftHandlerT (HandlerT f) = HandlerT $ liftIO . f . replaceToParent
{-# RULES "liftHandlerT (HandlerT site IO)" liftHandlerT = id #-}
instance MonadResourceBase m => MonadHandler (WidgetT site m) where
instance MonadIO m => MonadHandler (WidgetT site m) where
type HandlerSite (WidgetT site m) = site
liftHandlerT (HandlerT f) = WidgetT $ \_ref env -> liftIO $ f $ replaceToParent env
{-# RULES "liftHandlerT (WidgetT site IO)" forall f. liftHandlerT (HandlerT f) = WidgetT $ const f #-}
@ -55,7 +53,6 @@ instance MonadResourceBase m => MonadHandler (WidgetT site m) where
GO(IdentityT)
GO(ListT)
GO(MaybeT)
GOX(Error e, ErrorT e)
GO(ExceptT e)
GO(ReaderT r)
GO(StateT s)
@ -71,7 +68,7 @@ GO(ConduitM i o)
class MonadHandler m => MonadWidget m where
liftWidgetT :: WidgetT (HandlerSite m) IO a -> m a
instance MonadResourceBase m => MonadWidget (WidgetT site m) where
instance MonadIO m => MonadWidget (WidgetT site m) where
liftWidgetT (WidgetT f) = WidgetT $ \ref env -> liftIO $ f ref $ replaceToParent env
#define GO(T) instance MonadWidget m => MonadWidget (T m) where liftWidgetT = lift . liftWidgetT
@ -79,7 +76,6 @@ instance MonadResourceBase m => MonadWidget (WidgetT site m) where
GO(IdentityT)
GO(ListT)
GO(MaybeT)
GOX(Error e, ErrorT e)
GO(ExceptT e)
GO(ReaderT r)
GO(StateT s)

2
yesod-core/Yesod/Core/Content.hs
View File

@ -117,7 +117,7 @@ instance ToContent Javascript where
toContent = toContent . toLazyText . unJavascript
instance ToFlushBuilder builder => ToContent (CI.Pipe () () builder () (ResourceT IO) ()) where
toContent src = ContentSource $ CI.ConduitM (CI.mapOutput toFlushBuilder src >>=)
toContent src = ContentSource $ CI.ConduitT (CI.mapOutput toFlushBuilder src >>=)
instance ToFlushBuilder builder => ToContent (Source (ResourceT IO) builder) where
toContent src = ContentSource $ mapOutput toFlushBuilder src

18
yesod-core/Yesod/Core/Handler.hs
View File

@ -194,12 +194,12 @@ import Data.Monoid (mempty, mappend)
#endif
import Control.Applicative ((<|>))
import Control.Exception (evaluate, SomeException, throwIO)
import Control.Exception.Lifted (handle)
import Control.Exception (handle)
import Control.Monad (void, liftM, unless)
import qualified Control.Monad.Trans.Writer as Writer
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.IO.Unlift (MonadIO, liftIO, MonadUnliftIO, withRunInIO)
import qualified Network.HTTP.Types as H
import qualified Network.Wai as W
@ -233,7 +233,7 @@ import Yesod.Core.Content (ToTypedContent (..), simpleConte
import Yesod.Core.Internal.Util (formatRFC1123)
import Text.Blaze.Html (preEscapedToHtml, toHtml)
import qualified Data.IORef.Lifted as I
import qualified Data.IORef as I
import Data.Maybe (listToMaybe, mapMaybe)
import Data.Typeable (Typeable)
import Web.PathPieces (PathPiece(..))
@ -246,7 +246,6 @@ import Data.CaseInsensitive (CI, original)
import qualified Data.Conduit.List as CL
import Control.Monad.Trans.Resource (MonadResource, InternalState, runResourceT, withInternalState, getInternalState, liftResourceT, resourceForkIO)
import qualified System.PosixCompat.Files as PC
import Control.Monad.Trans.Control (control, MonadBaseControl)
import Data.Conduit (Source, transPipe, Flush (Flush), yield, Producer, Sink)
import qualified Yesod.Core.TypeCache as Cache
import qualified Data.Word8 as W8
@ -447,7 +446,8 @@ forkHandler :: (SomeException -> HandlerT site IO ()) -- ^ error handler
-> HandlerT site IO ()
forkHandler onErr handler = do
yesRunner <- handlerToIO
void $ liftResourceT $ resourceForkIO $ yesRunner $ handle onErr handler
void $ liftResourceT $ resourceForkIO $
liftIO $ handle (yesRunner . onErr) (yesRunner handler)
-- | Redirect to the given route.
-- HTTP status code 303 for HTTP 1.1 clients and 302 for HTTP 1.0
@ -664,10 +664,10 @@ sendWaiApplication = handlerError . HCWaiApp
--
-- @since 1.2.16
sendRawResponseNoConduit
:: (MonadHandler m, MonadBaseControl IO m)
:: (MonadHandler m, MonadUnliftIO m)
=> (IO S8.ByteString -> (S8.ByteString -> IO ()) -> m ())
-> m a
sendRawResponseNoConduit raw = control $ \runInIO ->
sendRawResponseNoConduit raw = withRunInIO $ \runInIO ->
liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback
$ \src sink -> void $ runInIO (raw src sink)
where
@ -679,10 +679,10 @@ sendRawResponseNoConduit raw = control $ \runInIO ->
-- Warp).
--
-- @since 1.2.7
sendRawResponse :: (MonadHandler m, MonadBaseControl IO m)
sendRawResponse :: (MonadHandler m, MonadUnliftIO m)
=> (Source IO S8.ByteString -> Sink S8.ByteString IO () -> m ())
-> m a
sendRawResponse raw = control $ \runInIO ->
sendRawResponse raw = withRunInIO $ \runInIO ->
liftIO $ throwIO $ HCWai $ flip W.responseRaw fallback
$ \src sink -> void $ runInIO $ raw (src' src) (CL.mapM_ sink)
where

2
yesod-core/Yesod/Core/Json.hs
View File

@ -104,7 +104,7 @@ provideJson = provideRep . return . J.toEncoding
-- @since 0.3.0
parseJsonBody :: (MonadHandler m, J.FromJSON a) => m (J.Result a)
parseJsonBody = do
eValue <- rawRequestBody $$ runCatchC (sinkParser JP.value')
eValue <- runConduit $ rawRequestBody .| runCatchC (sinkParser JP.value')
return $ case eValue of
Left e -> J.Error $ show e
Right value -> J.fromJSON value

56
yesod-core/Yesod/Core/Types.hs
View File

@ -19,13 +19,10 @@ import Data.Monoid (Monoid (..))
import Control.Arrow (first)
import Control.Exception (Exception)
import Control.Monad (liftM, ap)
import Control.Monad.Base (MonadBase (liftBase))
import Control.Monad.Catch (MonadMask (..), MonadCatch (..))
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Logger (LogLevel, LogSource,
MonadLogger (..))
import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState, MonadThrow (..), monadThrow, ResourceT)
import Control.Monad.Trans.Resource (MonadResource (..), InternalState, runInternalState, MonadThrow (..), throwM, ResourceT)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as L
import Data.Conduit (Flush, Source)
@ -417,14 +414,6 @@ instance Monad m => Monad (WidgetT site m) where
unWidgetT (f a) ref r
instance MonadIO m => MonadIO (WidgetT site m) where
liftIO = lift . liftIO
instance MonadBase b m => MonadBase b (WidgetT site m) where
liftBase = WidgetT . const . const . liftBase
instance MonadBaseControl b m => MonadBaseControl b (WidgetT site m) where
type StM (WidgetT site m) a = StM m a
liftBaseWith f = WidgetT $ \ref reader' ->
liftBaseWith $ \runInBase ->
f $ runInBase . (\(WidgetT w) -> w ref reader')
restoreM = WidgetT . const . const . restoreM
-- | @since 1.4.38
instance MonadUnliftIO m => MonadUnliftIO (WidgetT site m) where
{-# INLINE askUnliftIO #-}
@ -444,29 +433,8 @@ instance MonadTrans (WidgetT site) where
instance MonadThrow m => MonadThrow (WidgetT site m) where
throwM = lift . throwM
instance MonadCatch m => MonadCatch (HandlerT site m) where
catch (HandlerT m) c = HandlerT $ \r -> m r `catch` \e -> unHandlerT (c e) r
instance MonadMask m => MonadMask (HandlerT site m) where
mask a = HandlerT $ \e -> mask $ \u -> unHandlerT (a $ q u) e
where q u (HandlerT b) = HandlerT (u . b)
uninterruptibleMask a =
HandlerT $ \e -> uninterruptibleMask $ \u -> unHandlerT (a $ q u) e
where q u (HandlerT b) = HandlerT (u . b)
instance MonadCatch m => MonadCatch (WidgetT site m) where
catch (WidgetT m) c = WidgetT $ \ref r -> m ref r `catch` \e -> unWidgetT (c e) ref r
instance MonadMask m => MonadMask (WidgetT site m) where
mask a = WidgetT $ \ref e -> mask $ \u -> unWidgetT (a $ q u) ref e
where q u (WidgetT b) = WidgetT (\ref e -> u $ b ref e)
uninterruptibleMask a =
WidgetT $ \ref e -> uninterruptibleMask $ \u -> unWidgetT (a $ q u) ref e
where q u (WidgetT b) = WidgetT (\ref e -> u $ b ref e)
-- CPP to avoid a redundant constraints warning
#if MIN_VERSION_base(4,9,0)
instance (MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where
#else
instance (Applicative m, MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (WidgetT site m) where
#endif
instance MonadIO m => MonadResource (WidgetT site m) where
liftResourceT f = WidgetT $ \_ hd -> liftIO $ runInternalState f (handlerResource hd)
instance MonadIO m => MonadLogger (WidgetT site m) where
@ -495,8 +463,6 @@ instance Monad m => Monad (HandlerT site m) where
HandlerT x >>= f = HandlerT $ \r -> x r >>= \x' -> unHandlerT (f x') r
instance MonadIO m => MonadIO (HandlerT site m) where
liftIO = lift . liftIO
instance MonadBase b m => MonadBase b (HandlerT site m) where
liftBase = lift . liftBase
instance Monad m => MonadReader site (HandlerT site m) where
ask = HandlerT $ return . rheSite . handlerEnv
local f (HandlerT g) = HandlerT $ \hd -> g hd
@ -504,20 +470,6 @@ instance Monad m => MonadReader site (HandlerT site m) where
{ rheSite = f $ rheSite $ handlerEnv hd
}
}
-- | Note: although we provide a @MonadBaseControl@ instance, @lifted-base@'s
-- @fork@ function is incompatible with the underlying @ResourceT@ system.
-- Instead, if you must fork a separate thread, you should use
-- @resourceForkIO@.
--
-- Using fork usually leads to an exception that says
-- \"Control.Monad.Trans.Resource.register\': The mutable state is being accessed
-- after cleanup. Please contact the maintainers.\"
instance MonadBaseControl b m => MonadBaseControl b (HandlerT site m) where
type StM (HandlerT site m) a = StM m a
liftBaseWith f = HandlerT $ \reader' ->
liftBaseWith $ \runInBase ->
f $ runInBase . (\(HandlerT r) -> r reader')
restoreM = HandlerT . const . restoreM
-- | @since 1.4.38
instance MonadUnliftIO m => MonadUnliftIO (HandlerT site m) where
{-# INLINE askUnliftIO #-}
@ -526,9 +478,9 @@ instance MonadUnliftIO m => MonadUnliftIO (HandlerT site m) where
return (UnliftIO (unliftIO u . flip unHandlerT r))
instance MonadThrow m => MonadThrow (HandlerT site m) where
throwM = lift . monadThrow
throwM = lift . throwM
instance (MonadIO m, MonadBase IO m, MonadThrow m) => MonadResource (HandlerT site m) where
instance MonadIO m => MonadResource (HandlerT site m) where
liftResourceT f = HandlerT $ \hd -> liftIO $ runInternalState f (handlerResource hd)
instance MonadIO m => MonadLogger (HandlerT site m) where

2
yesod-core/test/YesodCoreTest/Cache.hs
View File

@ -15,7 +15,7 @@ import Network.Wai
import Network.Wai.Test
import Yesod.Core
import Data.IORef.Lifted
import UnliftIO.IORef
import Data.Typeable (Typeable)
import qualified Data.ByteString.Lazy.Char8 as L8

6
yesod-core/test/YesodCoreTest/ErrorHandling.hs
View File

@ -18,7 +18,9 @@ import Blaze.ByteString.Builder (Builder, fromByteString, toLazyByteString)
import Data.Monoid (mconcat)
import Data.Text (Text, pack)
import Control.Monad (forM_)
import qualified Control.Exception.Lifted as E
import Control.Monad.Trans.State (StateT (..))
import Control.Monad.Trans.Reader (ReaderT (..))
import qualified UnliftIO.Exception as E
data App = App
@ -217,6 +219,6 @@ caseGoodBuilder = runner $ do
caseError :: Int -> IO ()
caseError i = runner $ do
res <- request defaultRequest { pathInfo = ["error", pack $ show i] }
assertStatus 500 res `E.catch` \e -> do
ReaderT $ \r -> StateT $ \s -> runStateT (runReaderT (assertStatus 500 res) r) s `E.catch` \e -> do
liftIO $ print res
E.throwIO (e :: E.SomeException)

7
yesod-core/yesod-core.cabal
View File

@ -39,8 +39,6 @@ library
, old-locale >= 1.0.0.2 && < 1.1
, containers >= 0.2
, unordered-containers >= 0.2
, monad-control >= 1.0 && < 1.1
, transformers-base >= 0.4
, cookie >= 0.4.2 && < 0.5
, http-types >= 0.7
, case-insensitive >= 0.2
@ -53,15 +51,14 @@ library
, monad-logger >= 0.3.10 && < 0.4
, conduit >= 1.3
, resourcet >= 1.2
, lifted-base >= 0.1.2
, blaze-html >= 0.5
, blaze-markup >= 0.7.1
-- FIXME remove!
, data-default
, safe
, warp >= 3.0.2
, unix-compat
, conduit-extra
, exceptions >= 0.6
, deepseq >= 1.3
, deepseq-generics
, mwc-random
@ -196,7 +193,6 @@ test-suite tests
,transformers
, conduit
, containers
, lifted-base
, resourcet
, network
, async
@ -206,6 +202,7 @@ test-suite tests
, wai-extra
, mwc-random
, cookie >= 0.4.1 && < 0.5
, unliftio
ghc-options: -Wall
extensions: TemplateHaskell

2
yesod-static/Yesod/Static.hs
View File

@ -175,7 +175,7 @@ instance RenderRoute Static where
instance ParseRoute Static where
parseRoute (x, y) = Just $ StaticRoute x y
instance (MonadThrow m, MonadIO m, MonadBaseControl IO m)
instance (MonadThrow m, MonadUnliftIO m)
=> YesodSubDispatch Static (HandlerT master m) where
yesodSubDispatch YesodSubRunnerEnv {..} req =
ysreParentRunner base ysreParentEnv (fmap ysreToParentRoute route) req

49
yesod-websockets/Yesod/WebSockets.hs
View File

@ -34,19 +34,14 @@ module Yesod.WebSockets
, WS.ConnectionOptions (..)
) where
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
import qualified Network.Wai.Handler.WebSockets as WaiWS
import qualified Network.WebSockets as WS
import qualified Yesod.Core as Y
import Control.Exception (SomeException)
import Control.Exception.Enclosed (tryAny)
import UnliftIO (SomeException, tryAny, MonadIO, liftIO, MonadUnliftIO, withRunInIO, race, race_, concurrently, concurrently_)
-- | A transformer for a WebSockets handler.
--
@ -60,14 +55,14 @@ type WebSocketsT = ReaderT WS.Connection
-- instead.
--
-- Since 0.1.0
webSockets :: (Y.MonadBaseControl IO m, Y.MonadHandler m) => WebSocketsT m () -> m ()
webSockets :: (Y.MonadUnliftIO m, Y.MonadHandler m) => WebSocketsT m () -> m ()
webSockets = webSocketsOptions WS.defaultConnectionOptions
-- | Varient of 'webSockets' which allows you to specify
-- the WS.ConnectionOptions setttings when upgrading to a websocket connection.
--
-- Since 0.2.5
webSocketsOptions :: (Y.MonadBaseControl IO m, Y.MonadHandler m)
webSocketsOptions :: (Y.MonadUnliftIO m, Y.MonadHandler m)
=> WS.ConnectionOptions
-> WebSocketsT m ()
-> m ()
@ -81,7 +76,7 @@ webSocketsOptions opts = webSocketsOptionsWith opts $ const $ return $ Just $ WS
-- setttings when upgrading to a websocket connection.
--
-- Since 0.2.4
webSocketsWith :: (Y.MonadBaseControl IO m, Y.MonadHandler m)
webSocketsWith :: (Y.MonadUnliftIO m, Y.MonadHandler m)
=> (WS.RequestHead -> m (Maybe WS.AcceptRequest))
-- ^ A Nothing indicates that the websocket upgrade request should not happen
-- and instead the rest of the handler will be called instead. This allows
@ -98,7 +93,7 @@ webSocketsWith = webSocketsOptionsWith WS.defaultConnectionOptions
-- setttings when upgrading to a websocket connection.
--
-- Since 0.2.5
webSocketsOptionsWith :: (Y.MonadBaseControl IO m, Y.MonadHandler m)
webSocketsOptionsWith :: (Y.MonadUnliftIO m, Y.MonadHandler m)
=> WS.ConnectionOptions
-- ^ Custom websockets options
-> (WS.RequestHead -> m (Maybe WS.AcceptRequest))
@ -119,7 +114,7 @@ webSocketsOptionsWith wsConnOpts buildAr inner = do
Nothing -> return ()
Just ar ->
Y.sendRawResponseNoConduit
$ \src sink -> control $ \runInIO -> WaiWS.runWebSockets
$ \src sink -> withRunInIO $ \runInIO -> WaiWS.runWebSockets
wsConnOpts
rhead
(\pconn -> do
@ -227,35 +222,3 @@ 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)

4
yesod-websockets/yesod-websockets.cabal
View File

@ -24,10 +24,8 @@ library
, websockets >= 0.9
, transformers >= 0.2
, yesod-core >= 1.4
, monad-control >= 0.3
, unliftio
, conduit >= 1.0.15.1
, async >= 2.0.1.5
, enclosed-exceptions >= 1.0
source-repository head
type: git