diff --git a/yesod-auth/Yesod/Auth/GoogleEmail.hs b/yesod-auth/Yesod/Auth/GoogleEmail.hs deleted file mode 100644 index eb0b6cee..00000000 --- a/yesod-auth/Yesod/Auth/GoogleEmail.hs +++ /dev/null @@ -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|_{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" diff --git a/yesod-auth/Yesod/Auth/OpenId.hs b/yesod-auth/Yesod/Auth/OpenId.hs index f32ff747..fce1f1bf 100644 --- a/yesod-auth/Yesod/Auth/OpenId.hs +++ b/yesod-auth/Yesod/Auth/OpenId.hs @@ -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 diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index 1de994a2..21f78a81 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -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 diff --git a/yesod-core/Yesod/Core.hs b/yesod-core/Yesod/Core.hs index 1d5de1d1..2f81a9ba 100644 --- a/yesod-core/Yesod/Core.hs +++ b/yesod-core/Yesod/Core.hs @@ -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 diff --git a/yesod-core/Yesod/Core/Class/Handler.hs b/yesod-core/Yesod/Core/Class/Handler.hs index 8e447eab..6e979c2e 100644 --- a/yesod-core/Yesod/Core/Class/Handler.hs +++ b/yesod-core/Yesod/Core/Class/Handler.hs @@ -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) diff --git a/yesod-core/Yesod/Core/Content.hs b/yesod-core/Yesod/Core/Content.hs index d98d967e..d33d87ad 100644 --- a/yesod-core/Yesod/Core/Content.hs +++ b/yesod-core/Yesod/Core/Content.hs @@ -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 diff --git a/yesod-core/Yesod/Core/Handler.hs b/yesod-core/Yesod/Core/Handler.hs index bfd254d0..3395b3bd 100644 --- a/yesod-core/Yesod/Core/Handler.hs +++ b/yesod-core/Yesod/Core/Handler.hs @@ -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 diff --git a/yesod-core/Yesod/Core/Json.hs b/yesod-core/Yesod/Core/Json.hs index 245aad90..94c1e1b9 100644 --- a/yesod-core/Yesod/Core/Json.hs +++ b/yesod-core/Yesod/Core/Json.hs @@ -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 diff --git a/yesod-core/Yesod/Core/Types.hs b/yesod-core/Yesod/Core/Types.hs index fd4572de..680c13b8 100644 --- a/yesod-core/Yesod/Core/Types.hs +++ b/yesod-core/Yesod/Core/Types.hs @@ -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 diff --git a/yesod-core/test/YesodCoreTest/Cache.hs b/yesod-core/test/YesodCoreTest/Cache.hs index 04282f81..e1ba9204 100644 --- a/yesod-core/test/YesodCoreTest/Cache.hs +++ b/yesod-core/test/YesodCoreTest/Cache.hs @@ -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 diff --git a/yesod-core/test/YesodCoreTest/ErrorHandling.hs b/yesod-core/test/YesodCoreTest/ErrorHandling.hs index f8517b36..db8dfe1c 100644 --- a/yesod-core/test/YesodCoreTest/ErrorHandling.hs +++ b/yesod-core/test/YesodCoreTest/ErrorHandling.hs @@ -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) diff --git a/yesod-core/yesod-core.cabal b/yesod-core/yesod-core.cabal index dd5306ec..44e35973 100644 --- a/yesod-core/yesod-core.cabal +++ b/yesod-core/yesod-core.cabal @@ -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 diff --git a/yesod-static/Yesod/Static.hs b/yesod-static/Yesod/Static.hs index 636bd333..883bf62e 100644 --- a/yesod-static/Yesod/Static.hs +++ b/yesod-static/Yesod/Static.hs @@ -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 diff --git a/yesod-websockets/Yesod/WebSockets.hs b/yesod-websockets/Yesod/WebSockets.hs index 243d854f..2346b03c 100644 --- a/yesod-websockets/Yesod/WebSockets.hs +++ b/yesod-websockets/Yesod/WebSockets.hs @@ -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) diff --git a/yesod-websockets/yesod-websockets.cabal b/yesod-websockets/yesod-websockets.cabal index 81a9f147..70bfc00b 100644 --- a/yesod-websockets/yesod-websockets.cabal +++ b/yesod-websockets/yesod-websockets.cabal @@ -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