diff --git a/.travis.yml b/.travis.yml index ab790d0b..e9e0b6d7 100644 --- a/.travis.yml +++ b/.travis.yml @@ -11,7 +11,7 @@ # Use new container infrastructure to enable caching sudo: false -# Choose a lightweight base image; we provide our own build tools. +# Do not choose a language; we provide our own build tools. language: generic # Caching so the next build will be fast too. @@ -35,27 +35,12 @@ matrix: include: # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See: # https://github.com/hvr/multi-ghc-travis - #- env: BUILD=cabal GHCVER=7.0.4 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC 7.0.4" - # addons: {apt: {packages: [cabal-install-1.16,ghc-7.0.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - #- env: BUILD=cabal GHCVER=7.2.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC 7.2.2" - # addons: {apt: {packages: [cabal-install-1.16,ghc-7.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - #- env: BUILD=cabal GHCVER=7.4.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC 7.4.2" - # addons: {apt: {packages: [cabal-install-1.16,ghc-7.4.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - #- env: BUILD=cabal GHCVER=7.6.3 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 - # compiler: ": #GHC 7.6.3" - # addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - - env: BUILD=cabal GHCVER=7.8.4 CABALVER=1.18 HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #GHC 7.8.4" - addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - - env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7 - compiler: ": #GHC 7.10.3" - addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} - env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 compiler: ": #GHC 8.0.2" addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} + - env: BUILD=cabal GHCVER=8.2.2 CABALVER=2.0 HAPPYVER=1.19.5 ALEXVER=3.1.7 + compiler: ": #GHC 8.2.2" + addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} # Build with the newest GHC and cabal-install. This is an accepted failure, # see below. @@ -69,32 +54,40 @@ matrix: compiler: ": #stack default" addons: {apt: {packages: [libgmp-dev]}} - - env: BUILD=stack ARGS="--resolver lts-6" - compiler: ": #stack 7.10.3" + - env: BUILD=stack ARGS="--resolver lts-7" + compiler: ": #stack 8.0.1" addons: {apt: {packages: [libgmp-dev]}} - - env: BUILD=stack ARGS="--resolver lts-8" + - env: BUILD=stack ARGS="--resolver lts-9" compiler: ": #stack 8.0.2" addons: {apt: {packages: [libgmp-dev]}} + - env: BUILD=stack ARGS="--resolver lts-10" + compiler: ": #stack 8.2.2" + addons: {apt: {packages: [libgmp-dev]}} + # Nightly builds are allowed to fail - env: BUILD=stack ARGS="--resolver nightly" compiler: ": #stack nightly" addons: {apt: {packages: [libgmp-dev]}} - # Build on OS X in addition to Linux + # Build on macOS in addition to Linux - env: BUILD=stack ARGS="" compiler: ": #stack default osx" os: osx - - env: BUILD=stack ARGS="--resolver lts-6" - compiler: ": #stack 7.10.3 osx" + - env: BUILD=stack ARGS="--resolver lts-7" + compiler: ": #stack 8.0.1 osx" os: osx - - env: BUILD=stack ARGS="--resolver lts-8" + - env: BUILD=stack ARGS="--resolver lts-9" compiler: ": #stack 8.0.2 osx" os: osx + - env: BUILD=stack ARGS="--resolver lts-10" + compiler: ": #stack 8.2.2 osx" + os: osx + - env: BUILD=stack ARGS="--resolver nightly" compiler: ": #stack nightly osx" os: osx @@ -102,8 +95,6 @@ matrix: allow_failures: - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 - env: BUILD=stack ARGS="--resolver nightly" - - env: BUILD=cabal GHCVER=7.8.4 CABALVER=1.18 HAPPYVER=1.19.5 ALEXVER=3.1.7 - - env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7 before_install: # Using compiler above sets CC to an invalid value, so unset it @@ -139,11 +130,28 @@ install: - if [ -f configure.ac ]; then autoreconf -i; fi - | set -ex - if [ "$ARGS" = "--resolver nightly" ] - then - stack --install-ghc $ARGS build cabal-install - stack --install-ghc $ARGS solver --update-config - fi + case "$BUILD" in + stack) + # Add in extra-deps for older snapshots, as necessary + stack --no-terminal --install-ghc $ARGS test --bench --dry-run || ( \ + stack --no-terminal $ARGS build cabal-install && \ + stack --no-terminal $ARGS solver --update-config) + + # Build the dependencies + stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies + ;; + cabal) + cabal --version + travis_retry cabal update + + # Get the list of packages from the stack.yaml file. Note that + # this will also implicitly run hpack as necessary to generate + # the .cabal files needed by cabal-install. + PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') + + cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES + ;; + esac set +ex script: @@ -151,47 +159,28 @@ script: set -ex case "$BUILD" in stack) - if [ `uname` = "Darwin" ] - then - # Build dependencies with -O0 as well - echo "apply-ghc-options: everything" >> stack.yaml - - # Avoid OOM for building Cabal - stack --install-ghc --no-terminal $ARGS build Cabal --fast - - # Use slightly less intensive options on OS X due to Travis timeouts - stack --install-ghc --no-terminal $ARGS test --fast - else - # Avoid OOM for building Cabal - stack --install-ghc --no-terminal $ARGS build Cabal --fast - - stack --install-ghc --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps --pedantic - fi + stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps ;; cabal) - cabal --version - travis_retry cabal update - - # Get the list of packages from the stack.yaml file - PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') - cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES - ORIGDIR=$(pwd) - for dir in $PACKAGES - do - cd $dir - cabal check || [ "$CABALVER" == "1.16" ] - cabal sdist - PKGVER=$(cabal info . | awk '{print $2;exit}') - SRC_TGZ=$PKGVER.tar.gz - cd dist - tar zxfv "$SRC_TGZ" - cd "$PKGVER" - cabal configure --enable-tests - cabal build - cd $ORIGDIR - done + # Times out + #ORIGDIR=$(pwd) + #for dir in $PACKAGES + #do + # cd $dir + # cabal check || [ "$CABALVER" == "1.16" ] + # cabal sdist + # PKGVER=$(cabal info . | awk '{print $2;exit}') + # SRC_TGZ=$PKGVER.tar.gz + # cd dist + # tar zxfv "$SRC_TGZ" + # cd "$PKGVER" + # cabal configure --enable-tests --ghc-options -O0 + # cabal build + # cabal test + # cd $ORIGDIR + #done ;; esac set +ex diff --git a/stack.yaml b/stack.yaml index 043ac48d..c97d7cb5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -14,6 +14,25 @@ packages: - ./yesod-eventsource - ./yesod-websockets extra-deps: -- conduit-extra-1.2.2 -- unliftio-core-0.1.0.0 -- typed-process-0.2.0.0 +- unliftio-core-0.1.1.0 +- unliftio-0.2.4.0 +- authenticate-1.3.4 +- typed-process-0.2.1.0 +- conduit-1.3.0 +- conduit-extra-1.3.0 +- persistent-2.8.0 +- resourcet-1.2.0 +- mono-traversable-1.0.8.1 +- yaml-0.8.28 +- project-template-0.2.0.1 +- xml-conduit-1.8.0 +- wai-extra-3.0.22.0 +- monad-logger-0.3.28.1 +- html-conduit-1.3.0 +- http-conduit-2.3.0 +- persistent-sqlite-2.8.0 +- cookie-0.4.3 +- gauge-0.2.1 +- basement-0.0.6 +- foundation-0.0.19 +- memory-0.14.14 diff --git a/yesod-auth-oauth/ChangeLog.md b/yesod-auth-oauth/ChangeLog.md index fb5ca395..9e1ca6ea 100644 --- a/yesod-auth-oauth/ChangeLog.md +++ b/yesod-auth-oauth/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.6.0 + +* Upgrade to yesod-core 1.6.0 + ## 1.4.2 * Fix warnings diff --git a/yesod-auth-oauth/Yesod/Auth/OAuth.hs b/yesod-auth-oauth/Yesod/Auth/OAuth.hs index 9a5d3a0e..1a2d1852 100644 --- a/yesod-auth-oauth/Yesod/Auth/OAuth.hs +++ b/yesod-auth-oauth/Yesod/Auth/OAuth.hs @@ -1,5 +1,8 @@ {-# LANGUAGE DeriveDataTypeable, OverloadedStrings, QuasiQuotes #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} module Yesod.Auth.OAuth ( authOAuth , oauthUrl @@ -12,15 +15,15 @@ module Yesod.Auth.OAuth ) where import Control.Applicative as A ((<$>), (<*>)) import Control.Arrow ((***)) -import Control.Exception.Lifted +import UnliftIO.Exception import Control.Monad.IO.Class +import UnliftIO (MonadUnliftIO) import Data.ByteString (ByteString) import Data.Maybe import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Text.Encoding.Error (lenientDecode) -import Data.Typeable import Web.Authenticate.OAuth import Yesod.Auth import Yesod.Form @@ -35,26 +38,37 @@ instance Exception YesodOAuthException oauthUrl :: Text -> AuthRoute oauthUrl name = PluginR name ["forward"] -authOAuth :: YesodAuth m +authOAuth :: forall master. YesodAuth master => OAuth -- ^ 'OAuth' data-type for signing. - -> (Credential -> IO (Creds m)) -- ^ How to extract ident. - -> AuthPlugin m + -> (Credential -> IO (Creds master)) -- ^ How to extract ident. + -> AuthPlugin master authOAuth oauth mkCreds = AuthPlugin name dispatch login where name = T.pack $ oauthServerName oauth url = PluginR name [] lookupTokenSecret = bsToText . fromMaybe "" . lookup "oauth_token_secret" . unCredential + + oauthSessionName :: Text oauthSessionName = "__oauth_token_secret" + dispatch + :: ( MonadHandler m + , master ~ HandlerSite m + , Auth ~ SubHandlerSite m + , MonadUnliftIO m + ) + => Text + -> [Text] + -> m TypedContent dispatch "GET" ["forward"] = do - render <- lift getUrlRender + render <- getUrlRender tm <- getRouteToParent let oauth' = oauth { oauthCallback = Just $ encodeUtf8 $ render $ tm url } - master <- lift getYesod - tok <- lift $ getTemporaryCredential oauth' (authHttpManager master) + manager <- authHttpManager + tok <- getTemporaryCredential oauth' manager setSession oauthSessionName $ lookupTokenSecret tok redirect $ authorizeUrl oauth' tok - dispatch "GET" [] = lift $ do + dispatch "GET" [] = do Just tokSec <- lookupSession oauthSessionName deleteSession oauthSessionName reqTok <- @@ -72,8 +86,8 @@ authOAuth oauth mkCreds = AuthPlugin name dispatch login , ("oauth_token", encodeUtf8 oaTok) , ("oauth_token_secret", encodeUtf8 tokSec) ] - master <- getYesod - accTok <- getAccessToken oauth reqTok (authHttpManager master) + manager <- authHttpManager + accTok <- getAccessToken oauth reqTok manager creds <- liftIO $ mkCreds accTok setCredsRedirect creds dispatch _ _ = notFound diff --git a/yesod-auth-oauth/yesod-auth-oauth.cabal b/yesod-auth-oauth/yesod-auth-oauth.cabal index c21ac9e1..38f6d047 100644 --- a/yesod-auth-oauth/yesod-auth-oauth.cabal +++ b/yesod-auth-oauth/yesod-auth-oauth.cabal @@ -1,5 +1,5 @@ name: yesod-auth-oauth -version: 1.4.2 +version: 1.6.0 license: BSD3 license-file: LICENSE author: Hiromi Ishii @@ -23,12 +23,12 @@ library build-depends: base >= 4 && < 4.3 build-depends: authenticate-oauth >= 1.5 && < 1.7 , bytestring >= 0.9.1.4 - , yesod-core >= 1.4 && < 1.5 - , yesod-auth >= 1.4 && < 1.5 + , yesod-core >= 1.6 && < 1.7 + , yesod-auth >= 1.6 && < 1.7 , text >= 0.7 - , yesod-form >= 1.4 && < 1.5 + , yesod-form >= 1.6 && < 1.7 , transformers >= 0.2.2 && < 0.6 - , lifted-base >= 0.2 && < 0.3 + , unliftio exposed-modules: Yesod.Auth.OAuth ghc-options: -Wall diff --git a/yesod-auth/ChangeLog.md b/yesod-auth/ChangeLog.md index 095ccbd6..69ac6519 100644 --- a/yesod-auth/ChangeLog.md +++ b/yesod-auth/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.6.0 + +* Upgrade to yesod-core 1.6.0 + ## 1.4.21 * Add redirectToCurrent to Yesod.Auth module for controlling setUltDestCurrent in redirectLogin [#1461](https://github.com/yesodweb/yesod/pull/1461) diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index b382630a..baae2e9e 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/yesod-auth/Yesod/Auth.hs @@ -39,6 +39,7 @@ module Yesod.Auth -- * Exception , AuthException (..) -- * Helper + , MonadAuthHandler , AuthHandler -- * Internal , credsKey @@ -47,9 +48,9 @@ module Yesod.Auth , asHtml ) where -import Control.Applicative ((<$>)) import Control.Monad (when) import Control.Monad.Trans.Maybe +import UnliftIO (withRunInIO, MonadUnliftIO) import Yesod.Auth.Routes import Data.Aeson hiding (json) @@ -60,11 +61,11 @@ import qualified Data.Text as T import qualified Data.HashMap.Lazy as Map import Data.Monoid (Endo) import Network.HTTP.Client (Manager, Request, withResponse, Response, BodyReader) +import Network.HTTP.Client.TLS (getGlobalManager) import qualified Network.Wai as W import Yesod.Core -import Yesod.Core.Types (HandlerT(..), unHandlerT) import Yesod.Persist import Yesod.Auth.Message (AuthMessage, defaultMessage) import qualified Yesod.Auth.Message as Msg @@ -72,13 +73,13 @@ import Yesod.Form (FormMessage) import Data.Typeable (Typeable) import Control.Exception (Exception) import Network.HTTP.Types (Status, internalServerError500, unauthorized401) -import Control.Monad.Trans.Resource (MonadResourceBase) import qualified Control.Monad.Trans.Writer as Writer import Control.Monad (void) type AuthRoute = Route Auth -type AuthHandler master a = YesodAuth master => HandlerT Auth (HandlerT master IO) a +type MonadAuthHandler master m = (MonadHandler m, YesodAuth master, master ~ HandlerSite m, Auth ~ SubHandlerSite m, MonadUnliftIO m) +type AuthHandler master a = forall m. MonadAuthHandler master m => m a type Method = Text type Piece = Text @@ -94,7 +95,7 @@ data AuthenticationResult master data AuthPlugin master = AuthPlugin { apName :: Text , apDispatch :: Method -> [Piece] -> AuthHandler master TypedContent - , apLogin :: (Route Auth -> Route master) -> WidgetT master IO () + , apLogin :: (Route Auth -> Route master) -> WidgetFor master () } getAuth :: a -> Auth @@ -111,8 +112,8 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage type AuthId master -- | specify the layout. Uses defaultLayout by default - authLayout :: WidgetT master IO () -> HandlerT master IO Html - authLayout = defaultLayout + authLayout :: WidgetFor master () -> AuthHandler master Html + authLayout = liftHandler . defaultLayout -- | Default destination on successful login, if no other -- destination exists. @@ -126,8 +127,8 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage -- -- Default implementation is in terms of @'getAuthId'@ -- - -- @since 1.4.4 - authenticate :: Creds master -> HandlerT master IO (AuthenticationResult master) + -- @since: 1.4.4 + authenticate :: Creds master -> AuthHandler master (AuthenticationResult master) authenticate creds = do muid <- getAuthId creds @@ -137,7 +138,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage -- -- Default implementation is in terms of @'authenticate'@ -- - getAuthId :: Creds master -> HandlerT master IO (Maybe (AuthId master)) + getAuthId :: Creds master -> AuthHandler master (Maybe (AuthId master)) getAuthId creds = do auth <- authenticate creds @@ -167,7 +168,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage -- > lift $ redirect HomeR -- or any other Handler code you want -- > defaultLoginHandler -- - loginHandler :: HandlerT Auth (HandlerT master IO) Html + loginHandler :: AuthHandler master Html loginHandler = defaultLoginHandler -- | Used for i18n of messages provided by this package. @@ -193,15 +194,16 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage -- type. This allows backends to reuse persistent connections. If none of -- the backends you're using use HTTP connections, you can safely return -- @error \"authHttpManager\"@ here. - authHttpManager :: master -> Manager + authHttpManager :: AuthHandler master Manager + authHttpManager = liftIO getGlobalManager -- | Called on a successful login. By default, calls -- @addMessageI "success" NowLoggedIn@. - onLogin :: HandlerT master IO () + onLogin :: AuthHandler master () onLogin = addMessageI "success" Msg.NowLoggedIn -- | Called on logout. By default, does nothing - onLogout :: HandlerT master IO () + onLogout :: AuthHandler master () onLogout = return () -- | Retrieves user credentials, if user is authenticated. @@ -213,16 +215,16 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage -- other than a browser. -- -- @since 1.2.0 - maybeAuthId :: HandlerT master IO (Maybe (AuthId master)) + maybeAuthId :: AuthHandler master (Maybe (AuthId master)) default maybeAuthId :: (YesodAuthPersist master, Typeable (AuthEntity master)) - => HandlerT master IO (Maybe (AuthId master)) + => AuthHandler master (Maybe (AuthId master)) maybeAuthId = defaultMaybeAuthId -- | Called on login error for HTTP requests. By default, calls -- @addMessage@ with "error" as status and redirects to @dest@. - onErrorHtml :: (MonadResourceBase m) => Route master -> Text -> HandlerT master m Html + onErrorHtml :: Route master -> Text -> AuthHandler master Html onErrorHtml dest msg = do addMessage "error" $ toHtml msg fmap asHtml $ redirect dest @@ -232,10 +234,14 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage -- -- The HTTP 'Request' is given in case it is useful to change behavior based on inspecting the request. -- This is an experimental API that is not broadly used throughout the yesod-auth code base - runHttpRequest :: Request -> (Response BodyReader -> HandlerT master IO a) -> HandlerT master IO a + runHttpRequest + :: MonadAuthHandler master m + => Request + -> (Response BodyReader -> m a) + -> m a runHttpRequest req inner = do - man <- authHttpManager Control.Applicative.<$> getYesod - HandlerT $ \t -> withResponse req man $ \res -> unHandlerT (inner res) t + man <- authHttpManager + withRunInIO $ \run -> withResponse req man $ run . inner {-# MINIMAL loginDest, logoutDest, (authenticate | getAuthId), authPlugins, authHttpManager #-} @@ -256,7 +262,7 @@ credsKey = "_ID" -- @since 1.1.2 defaultMaybeAuthId :: (YesodAuthPersist master, Typeable (AuthEntity master)) - => HandlerT master IO (Maybe (AuthId master)) + => AuthHandler master (Maybe (AuthId master)) defaultMaybeAuthId = runMaybeT $ do s <- MaybeT $ lookupSession credsKey aid <- MaybeT $ return $ fromPathPiece s @@ -265,7 +271,8 @@ defaultMaybeAuthId = runMaybeT $ do cachedAuth :: (YesodAuthPersist master, Typeable (AuthEntity master)) - => AuthId master -> HandlerT master IO (Maybe (AuthEntity master)) + => AuthId master + -> AuthHandler master (Maybe (AuthEntity master)) cachedAuth = fmap unCachedMaybeAuth . cached @@ -282,48 +289,53 @@ cachedAuth defaultLoginHandler :: AuthHandler master Html defaultLoginHandler = do tp <- getRouteToParent - lift $ authLayout $ do + authLayout $ do setTitleI Msg.LoginTitle master <- getYesod mapM_ (flip apLogin tp) (authPlugins master) -loginErrorMessageI :: (MonadResourceBase m, YesodAuth master) - => Route child - -> AuthMessage - -> HandlerT child (HandlerT master m) TypedContent +loginErrorMessageI + :: Route Auth + -> AuthMessage + -> AuthHandler master TypedContent loginErrorMessageI dest msg = do toParent <- getRouteToParent - lift $ loginErrorMessageMasterI (toParent dest) msg + loginErrorMessageMasterI (toParent dest) msg -loginErrorMessageMasterI :: (YesodAuth master, MonadResourceBase m, RenderMessage master AuthMessage) - => Route master - -> AuthMessage - -> HandlerT master m TypedContent +loginErrorMessageMasterI + :: Route master + -> AuthMessage + -> AuthHandler master TypedContent loginErrorMessageMasterI dest msg = do mr <- getMessageRender loginErrorMessage dest (mr msg) -- | For HTML, set the message and redirect to the route. -- For JSON, send the message and a 401 status -loginErrorMessage :: (YesodAuth master, MonadResourceBase m) - => Route master +loginErrorMessage + :: Route master -> Text - -> HandlerT master m TypedContent + -> AuthHandler master TypedContent loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg) -messageJson401 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent +messageJson401 + :: MonadAuthHandler master m + => Text + -> m Html + -> m TypedContent messageJson401 = messageJsonStatus unauthorized401 -messageJson500 :: MonadResourceBase m => Text -> HandlerT master m Html -> HandlerT master m TypedContent +messageJson500 :: MonadAuthHandler master m => Text -> m Html -> m TypedContent messageJson500 = messageJsonStatus internalServerError500 -messageJsonStatus :: MonadResourceBase m - => Status - -> Text - -> HandlerT master m Html - -> HandlerT master m TypedContent +messageJsonStatus + :: MonadAuthHandler master m + => Status + -> Text + -> m Html + -> m TypedContent messageJsonStatus status msg html = selectRep $ do provideRep html provideRep $ do @@ -335,9 +347,9 @@ provideJsonMessage :: Monad m => Text -> Writer.Writer (Endo [ProvidedRep m]) () provideJsonMessage msg = provideRep $ return $ object ["message" .= msg] -setCredsRedirect :: YesodAuth master - => Creds master -- ^ new credentials - -> HandlerT master IO TypedContent +setCredsRedirect + :: Creds master -- ^ new credentials + -> AuthHandler master TypedContent setCredsRedirect creds = do y <- getYesod auth <- authenticate creds @@ -376,10 +388,9 @@ setCredsRedirect creds = do return $ renderAuthMessage master langs msg -- | Sets user credentials for the session after checking them with authentication backends. -setCreds :: YesodAuth master - => Bool -- ^ if HTTP redirects should be done +setCreds :: Bool -- ^ if HTTP redirects should be done -> Creds master -- ^ new credentials - -> HandlerT master IO () + -> AuthHandler master () setCreds doRedirects creds = if doRedirects then void $ setCredsRedirect creds @@ -389,10 +400,11 @@ setCreds doRedirects creds = _ -> return () -- | same as defaultLayoutJson, but uses authLayout -authLayoutJson :: (YesodAuth site, ToJSON j) - => WidgetT site IO () -- ^ HTML - -> HandlerT site IO j -- ^ JSON - -> HandlerT site IO TypedContent +authLayoutJson + :: (ToJSON j, MonadAuthHandler master m) + => WidgetFor master () -- ^ HTML + -> m j -- ^ JSON + -> m TypedContent authLayoutJson w json = selectRep $ do provideRep $ authLayout w provideRep $ fmap toJSON json @@ -400,9 +412,8 @@ authLayoutJson w json = selectRep $ do -- | Clears current user credentials for the session. -- -- @since 1.1.7 -clearCreds :: YesodAuth master - => Bool -- ^ if HTTP redirect to 'logoutDest' should be done - -> HandlerT master IO () +clearCreds :: Bool -- ^ if HTTP redirect to 'logoutDest' should be done + -> AuthHandler master () clearCreds doRedirects = do y <- getYesod onLogout @@ -411,7 +422,7 @@ clearCreds doRedirects = do redirectUltDest $ logoutDest y getCheckR :: AuthHandler master TypedContent -getCheckR = lift $ do +getCheckR = do creds <- maybeAuthId authLayoutJson (do setTitle "Authentication Status" @@ -432,7 +443,7 @@ $nothing ] setUltDestReferer' :: AuthHandler master () -setUltDestReferer' = lift $ do +setUltDestReferer' = do master <- getYesod when (redirectToReferer master) setUltDestReferer @@ -440,14 +451,16 @@ getLoginR :: AuthHandler master Html getLoginR = setUltDestReferer' >> loginHandler getLogoutR :: AuthHandler master () -getLogoutR = setUltDestReferer' >> redirectToPost LogoutR +getLogoutR = do + tp <- getRouteToParent + setUltDestReferer' >> redirectToPost (tp LogoutR) postLogoutR :: AuthHandler master () -postLogoutR = lift $ clearCreds True +postLogoutR = clearCreds True handlePluginR :: Text -> [Text] -> AuthHandler master TypedContent handlePluginR plugin pieces = do - master <- lift getYesod + master <- getYesod env <- waiRequest let method = decodeUtf8With lenientDecode $ W.requestMethod env case filter (\x -> apName x == plugin) (authPlugins master) of @@ -464,17 +477,16 @@ maybeAuth :: ( YesodAuthPersist master , Key val ~ AuthId master , PersistEntity val , Typeable val - ) => HandlerT master IO (Maybe (Entity val)) -maybeAuth = runMaybeT $ do - (aid, ae) <- MaybeT maybeAuthPair - return $ Entity aid ae + ) => AuthHandler master (Maybe (Entity val)) +maybeAuth = fmap (fmap (uncurry Entity)) maybeAuthPair -- | Similar to 'maybeAuth', but doesn’t assume that you are using a -- Persistent database. -- -- @since 1.4.0 -maybeAuthPair :: (YesodAuthPersist master, Typeable (AuthEntity master)) - => HandlerT master IO (Maybe (AuthId master, AuthEntity master)) +maybeAuthPair + :: (YesodAuthPersist master, Typeable (AuthEntity master)) + => AuthHandler master (Maybe (AuthId master, AuthEntity master)) maybeAuthPair = runMaybeT $ do aid <- MaybeT maybeAuthId ae <- MaybeT $ cachedAuth aid @@ -505,27 +517,16 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where type AuthEntity master :: * type AuthEntity master = KeyEntity (AuthId master) - getAuthEntity :: AuthId master -> HandlerT master IO (Maybe (AuthEntity master)) + getAuthEntity :: AuthId master -> AuthHandler master (Maybe (AuthEntity master)) -#if MIN_VERSION_persistent(2,5,0) default getAuthEntity :: ( YesodPersistBackend master ~ backend , PersistRecordBackend (AuthEntity master) backend , Key (AuthEntity master) ~ AuthId master , PersistStore backend ) - => AuthId master -> HandlerT master IO (Maybe (AuthEntity master)) -#else - default getAuthEntity - :: ( YesodPersistBackend master - ~ PersistEntityBackend (AuthEntity master) - , Key (AuthEntity master) ~ AuthId master - , PersistStore (YesodPersistBackend master) - , PersistEntity (AuthEntity master) - ) - => AuthId master -> HandlerT master IO (Maybe (AuthEntity master)) -#endif - getAuthEntity = runDB . get + => AuthId master -> AuthHandler master (Maybe (AuthEntity master)) + getAuthEntity = liftHandler . runDB . get type family KeyEntity key @@ -535,7 +536,7 @@ type instance KeyEntity (Key x) = x -- authenticated or responds with error 401 if this is an API client (expecting JSON). -- -- @since 1.1.0 -requireAuthId :: YesodAuth master => HandlerT master IO (AuthId master) +requireAuthId :: AuthHandler master (AuthId master) requireAuthId = maybeAuthId >>= maybe handleAuthLack return -- | Similar to 'maybeAuth', but redirects to a login page if user is not @@ -547,23 +548,26 @@ requireAuth :: ( YesodAuthPersist master , Key val ~ AuthId master , PersistEntity val , Typeable val - ) => HandlerT master IO (Entity val) + ) => AuthHandler master (Entity val) requireAuth = maybeAuth >>= maybe handleAuthLack return -- | Similar to 'requireAuth', but not tied to Persistent's 'Entity' type. -- Instead, the 'AuthId' and 'AuthEntity' are returned in a tuple. -- -- @since 1.4.0 -requireAuthPair :: (YesodAuthPersist master, Typeable (AuthEntity master)) - => HandlerT master IO (AuthId master, AuthEntity master) +requireAuthPair + :: ( YesodAuthPersist master + , Typeable (AuthEntity master) + ) + => AuthHandler master (AuthId master, AuthEntity master) requireAuthPair = maybeAuthPair >>= maybe handleAuthLack return -handleAuthLack :: YesodAuth master => HandlerT master IO a +handleAuthLack :: AuthHandler master a handleAuthLack = do aj <- acceptsJson if aj then notAuthenticated else redirectLogin -redirectLogin :: YesodAuth master => HandlerT master IO a +redirectLogin :: AuthHandler master a redirectLogin = do y <- getYesod when (redirectToCurrent y) setUltDestCurrent @@ -578,7 +582,7 @@ data AuthException = InvalidFacebookResponse deriving (Show, Typeable) instance Exception AuthException -instance YesodAuth master => YesodSubDispatch Auth (HandlerT master IO) where +instance YesodAuth master => YesodSubDispatch Auth master where yesodSubDispatch = $(mkYesodSubDispatch resourcesAuth) asHtml :: Html -> Html diff --git a/yesod-auth/Yesod/Auth/BrowserId.hs b/yesod-auth/Yesod/Auth/BrowserId.hs index a63ed0e1..c7e08421 100644 --- a/yesod-auth/Yesod/Auth/BrowserId.hs +++ b/yesod-auth/Yesod/Auth/BrowserId.hs @@ -70,20 +70,21 @@ authBrowserId bis@BrowserIdSettings {..} = AuthPlugin , apDispatch = \m ps -> case (m, ps) of ("GET", [assertion]) -> do - master <- lift getYesod audience <- case bisAudience of Just a -> return a Nothing -> do r <- getUrlRender - return $ T.takeWhile (/= '/') $ stripScheme $ r LoginR - memail <- lift $ checkAssertion audience assertion (authHttpManager master) + tm <- getRouteToParent + return $ T.takeWhile (/= '/') $ stripScheme $ r $ tm LoginR + manager <- authHttpManager + memail <- checkAssertion audience assertion manager case memail of Nothing -> do $logErrorS "yesod-auth" "BrowserID assertion failure" tm <- getRouteToParent - lift $ loginErrorMessage (tm LoginR) "BrowserID login error." - Just email -> lift $ setCredsRedirect Creds + loginErrorMessage (tm LoginR) "BrowserID login error." + Just email -> setCredsRedirect Creds { credsPlugin = pid , credsIdent = email , credsExtra = [] @@ -116,7 +117,7 @@ $newline never createOnClickOverride :: BrowserIdSettings -> (Route Auth -> Route master) -> Maybe (Route master) - -> WidgetT master IO Text + -> WidgetFor master Text createOnClickOverride BrowserIdSettings {..} toMaster mOnRegistration = do unless bisLazyLoad $ addScriptRemote browserIdJs onclick <- newIdent @@ -165,5 +166,5 @@ createOnClickOverride BrowserIdSettings {..} toMaster mOnRegistration = do -- name. createOnClick :: BrowserIdSettings -> (Route Auth -> Route master) - -> WidgetT master IO Text + -> WidgetFor master Text createOnClick bidSettings toMaster = createOnClickOverride bidSettings toMaster Nothing diff --git a/yesod-auth/Yesod/Auth/Dummy.hs b/yesod-auth/Yesod/Auth/Dummy.hs index 9e4611d6..721d6311 100644 --- a/yesod-auth/Yesod/Auth/Dummy.hs +++ b/yesod-auth/Yesod/Auth/Dummy.hs @@ -1,5 +1,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} -- | Provides a dummy authentication module that simply lets a user specify -- his/her identifier. This is not intended for real world use, just for -- testing. @@ -16,8 +18,8 @@ authDummy = AuthPlugin "dummy" dispatch login where dispatch "POST" [] = do - ident <- lift $ runInputPost $ ireq textField "ident" - lift $ setCredsRedirect $ Creds "dummy" ident [] + ident <- runInputPost $ ireq textField "ident" + setCredsRedirect $ Creds "dummy" ident [] dispatch _ _ = notFound url = PluginR "dummy" [] login authToMaster = do diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs index 51cbea7c..38afc51e 100644 --- a/yesod-auth/Yesod/Auth/Email.hs +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -186,29 +186,29 @@ class ( YesodAuth site -- has not yet been verified. -- -- @since 1.1.0 - addUnverified :: Email -> VerKey -> HandlerT site IO (AuthEmailId site) + addUnverified :: Email -> VerKey -> AuthHandler site (AuthEmailId site) -- | Send an email to the given address to verify ownership. -- -- @since 1.1.0 - sendVerifyEmail :: Email -> VerKey -> VerUrl -> HandlerT site IO () + sendVerifyEmail :: Email -> VerKey -> VerUrl -> AuthHandler site () -- | Get the verification key for the given email ID. -- -- @since 1.1.0 - getVerifyKey :: AuthEmailId site -> HandlerT site IO (Maybe VerKey) + getVerifyKey :: AuthEmailId site -> AuthHandler site (Maybe VerKey) -- | Set the verification key for the given email ID. -- -- @since 1.1.0 - setVerifyKey :: AuthEmailId site -> VerKey -> HandlerT site IO () + setVerifyKey :: AuthEmailId site -> VerKey -> AuthHandler site () -- | Hash and salt a password -- -- Default: 'saltPass'. -- -- @since 1.4.20 - hashAndSaltPassword :: Text -> HandlerT site IO SaltedPass + hashAndSaltPassword :: Text -> AuthHandler site SaltedPass hashAndSaltPassword = liftIO . saltPass -- | Verify a password matches the stored password for the given account. @@ -216,7 +216,7 @@ class ( YesodAuth site -- Default: Fetch a password with 'getPassword' and match using 'Yesod.Auth.Util.PasswordStore.verifyPassword'. -- -- @since 1.4.20 - verifyPassword :: Text -> SaltedPass -> HandlerT site IO Bool + verifyPassword :: Text -> SaltedPass -> AuthHandler site Bool verifyPassword plain salted = return $ isValidPass plain salted -- | Verify the email address on the given account. @@ -228,28 +228,28 @@ class ( YesodAuth site -- See . -- -- @since 1.1.0 - verifyAccount :: AuthEmailId site -> HandlerT site IO (Maybe (AuthId site)) + verifyAccount :: AuthEmailId site -> AuthHandler site (Maybe (AuthId site)) -- | Get the salted password for the given account. -- -- @since 1.1.0 - getPassword :: AuthId site -> HandlerT site IO (Maybe SaltedPass) + getPassword :: AuthId site -> AuthHandler site (Maybe SaltedPass) -- | Set the salted password for the given account. -- -- @since 1.1.0 - setPassword :: AuthId site -> SaltedPass -> HandlerT site IO () + setPassword :: AuthId site -> SaltedPass -> AuthHandler site () -- | Get the credentials for the given @Identifier@, which may be either an -- email address or some other identification (e.g., username). -- -- @since 1.2.0 - getEmailCreds :: Identifier -> HandlerT site IO (Maybe (EmailCreds site)) + getEmailCreds :: Identifier -> AuthHandler site (Maybe (EmailCreds site)) -- | Get the email address for the given email ID. -- -- @since 1.1.0 - getEmail :: AuthEmailId site -> HandlerT site IO (Maybe Email) + getEmail :: AuthEmailId site -> AuthHandler site (Maybe Email) -- | Generate a random alphanumeric string. -- @@ -268,7 +268,7 @@ class ( YesodAuth site -- Default: if the user logged in via an email link do not require a password. -- -- @since 1.2.1 - needOldPassword :: AuthId site -> HandlerT site IO Bool + needOldPassword :: AuthId site -> AuthHandler site Bool needOldPassword aid' = do mkey <- lookupSession loginLinkKey case mkey >>= readMay . TS.unpack of @@ -280,7 +280,7 @@ class ( YesodAuth site -- | Check that the given plain-text password meets minimum security standards. -- -- Default: password is at least three characters. - checkPasswordSecurity :: AuthId site -> Text -> HandlerT site IO (Either Text ()) + checkPasswordSecurity :: AuthId site -> Text -> AuthHandler site (Either Text ()) checkPasswordSecurity _ x | TS.length x >= 3 = return $ Right () | otherwise = return $ Left "Password must be at least three characters" @@ -288,7 +288,7 @@ class ( YesodAuth site -- | Response after sending a confirmation email. -- -- @since 1.2.2 - confirmationEmailSentResponse :: Text -> HandlerT site IO TypedContent + confirmationEmailSentResponse :: Text -> AuthHandler site TypedContent confirmationEmailSentResponse identifier = do mr <- getMessageRender selectRep $ do @@ -314,7 +314,7 @@ class ( YesodAuth site -- Default: 'defaultEmailLoginHandler'. -- -- @since 1.4.17 - emailLoginHandler :: (Route Auth -> Route site) -> WidgetT site IO () + emailLoginHandler :: (Route Auth -> Route site) -> WidgetFor site () emailLoginHandler = defaultEmailLoginHandler @@ -325,7 +325,7 @@ class ( YesodAuth site -- Default: 'defaultRegisterHandler'. -- -- @since: 1.2.6 - registerHandler :: HandlerT Auth (HandlerT site IO) Html + registerHandler :: AuthHandler site Html registerHandler = defaultRegisterHandler -- | Handler called to render the \"forgot password\" page. @@ -335,7 +335,7 @@ class ( YesodAuth site -- Default: 'defaultForgotPasswordHandler'. -- -- @since: 1.2.6 - forgotPasswordHandler :: HandlerT Auth (HandlerT site IO) Html + forgotPasswordHandler :: AuthHandler site Html forgotPasswordHandler = defaultForgotPasswordHandler -- | Handler called to render the \"set password\" page. The @@ -351,7 +351,7 @@ class ( YesodAuth site -- field for the old password should be presented. -- Otherwise, just two fields for the new password are -- needed. - -> HandlerT Auth (HandlerT site IO) TypedContent + -> AuthHandler site TypedContent setPasswordHandler = defaultSetPasswordHandler authEmail :: (YesodAuthEmail m) => AuthPlugin m @@ -371,15 +371,18 @@ authEmail = dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse dispatch _ _ = notFound -getRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html +getRegisterR :: YesodAuthEmail master => AuthHandler master Html getRegisterR = registerHandler -- | Default implementation of 'emailLoginHandler'. -- -- @since 1.4.17 -defaultEmailLoginHandler :: YesodAuthEmail master => (Route Auth -> Route master) -> WidgetT master IO () +defaultEmailLoginHandler + :: YesodAuthEmail master + => (Route Auth -> Route master) + -> WidgetFor master () defaultEmailLoginHandler toParent = do - (widget, enctype) <- liftWidgetT $ generateFormPost loginForm + (widget, enctype) <- generateFormPost loginForm [whamlet|
@@ -437,11 +440,11 @@ defaultEmailLoginHandler toParent = do -- | Default implementation of 'registerHandler'. -- -- @since 1.2.6 -defaultRegisterHandler :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html +defaultRegisterHandler :: YesodAuthEmail master => AuthHandler master Html defaultRegisterHandler = do - (widget, enctype) <- lift $ generateFormPost registrationForm + (widget, enctype) <- generateFormPost registrationForm toParentRoute <- getRouteToParent - lift $ authLayout $ do + authLayout $ do setTitleI Msg.RegisterLong [whamlet|

_{Msg.EnterEmail} @@ -480,14 +483,14 @@ parseEmail = withObject "email" (\obj -> do registerHelper :: YesodAuthEmail master => Bool -- ^ allow usernames? -> Route Auth - -> HandlerT Auth (HandlerT master IO) TypedContent + -> AuthHandler master TypedContent registerHelper allowUsername dest = do - y <- lift getYesod + y <- getYesod checkCsrfHeaderOrParam defaultCsrfHeaderName defaultCsrfParamName pidentifier <- lookupPostParam "email" midentifier <- case pidentifier of Nothing -> do - (jidentifier :: Result Value) <- lift parseCheckJsonBody + (jidentifier :: Result Value) <- parseCheckJsonBody case jidentifier of Error _ -> return Nothing Success val -> return $ parseMaybe parseEmail val @@ -502,43 +505,44 @@ registerHelper allowUsername dest = do case eidentifier of Left route -> loginErrorMessageI dest route Right identifier -> do - mecreds <- lift $ getEmailCreds identifier + mecreds <- getEmailCreds identifier registerCreds <- case mecreds of Just (EmailCreds lid _ _ (Just key) email) -> return $ Just (lid, key, email) Just (EmailCreds lid _ _ Nothing email) -> do key <- liftIO $ randomKey y - lift $ setVerifyKey lid key + setVerifyKey lid key return $ Just (lid, key, email) Nothing | allowUsername -> return Nothing | otherwise -> do key <- liftIO $ randomKey y - lid <- lift $ addUnverified identifier key + lid <- addUnverified identifier key return $ Just (lid, key, identifier) case registerCreds of Nothing -> loginErrorMessageI dest (Msg.IdentifierNotFound identifier) Just (lid, verKey, email) -> do render <- getUrlRender - let verUrl = render $ verifyR (toPathPiece lid) verKey - lift $ sendVerifyEmail email verKey verUrl - lift $ confirmationEmailSentResponse identifier + tp <- getRouteToParent + let verUrl = render $ tp $ verifyR (toPathPiece lid) verKey + sendVerifyEmail email verKey verUrl + confirmationEmailSentResponse identifier -postRegisterR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent +postRegisterR :: YesodAuthEmail master => AuthHandler master TypedContent postRegisterR = registerHelper False registerR -getForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html +getForgotPasswordR :: YesodAuthEmail master => AuthHandler master Html getForgotPasswordR = forgotPasswordHandler -- | Default implementation of 'forgotPasswordHandler'. -- -- @since 1.2.6 -defaultForgotPasswordHandler :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) Html +defaultForgotPasswordHandler :: YesodAuthEmail master => AuthHandler master Html defaultForgotPasswordHandler = do - (widget, enctype) <- lift $ generateFormPost forgotPasswordForm + (widget, enctype) <- generateFormPost forgotPasswordForm toParent <- getRouteToParent - lift $ authLayout $ do + authLayout $ do setTitleI Msg.PasswordResetTitle [whamlet|

_{Msg.PasswordResetPrompt} @@ -569,35 +573,36 @@ defaultForgotPasswordHandler = do fsAttrs = [("autofocus", "")] } -postForgotPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent +postForgotPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent postForgotPasswordR = registerHelper True forgotPasswordR getVerifyR :: YesodAuthEmail site => AuthEmailId site -> Text - -> HandlerT Auth (HandlerT site IO) TypedContent + -> AuthHandler site TypedContent getVerifyR lid key = do - realKey <- lift $ getVerifyKey lid - memail <- lift $ getEmail lid - mr <- lift getMessageRender + realKey <- getVerifyKey lid + memail <- getEmail lid + mr <- getMessageRender case (realKey == Just key, memail) of (True, Just email) -> do - muid <- lift $ verifyAccount lid + muid <- verifyAccount lid case muid of Nothing -> invalidKey mr Just uid -> do - lift $ setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid? - lift $ setLoginLinkKey uid + setCreds False $ Creds "email-verify" email [("verifiedEmail", email)] -- FIXME uid? + setLoginLinkKey uid let msgAv = Msg.AddressVerified selectRep $ do provideRep $ do - lift $ addMessageI "success" msgAv - fmap asHtml $ redirect setpassR + addMessageI "success" msgAv + tp <- getRouteToParent + fmap asHtml $ redirect $ tp setpassR provideJsonMessage $ mr msgAv _ -> invalidKey mr where msgIk = Msg.InvalidKey - invalidKey mr = messageJson401 (mr msgIk) $ lift $ authLayout $ do + invalidKey mr = messageJson401 (mr msgIk) $ authLayout $ do setTitleI msgIk [whamlet| $newline never @@ -612,16 +617,16 @@ parseCreds = withObject "creds" (\obj -> do return (email', pass)) -postLoginR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent +postLoginR :: YesodAuthEmail master => AuthHandler master TypedContent postLoginR = do - result <- lift $ runInputPostResult $ (,) + result <- runInputPostResult $ (,) <$> ireq textField "email" <*> ireq textField "password" midentifier <- case result of FormSuccess (iden, pass) -> return $ Just (iden, pass) _ -> do - (creds :: Result Value) <- lift parseCheckJsonBody + (creds :: Result Value) <- parseCheckJsonBody case creds of Error _ -> return Nothing Success val -> return $ parseMaybe parseCreds val @@ -629,18 +634,18 @@ postLoginR = do case midentifier of Nothing -> loginErrorMessageI LoginR Msg.NoIdentifierProvided Just (identifier, pass) -> do - mecreds <- lift $ getEmailCreds identifier + mecreds <- getEmailCreds identifier maid <- case ( mecreds >>= emailCredsAuthId , emailCredsEmail <$> mecreds , emailCredsStatus <$> mecreds ) of (Just aid, Just email', Just True) -> do - mrealpass <- lift $ getPassword aid + mrealpass <- getPassword aid case mrealpass of Nothing -> return Nothing Just realpass -> do - passValid <- lift $ verifyPassword pass realpass + passValid <- verifyPassword pass realpass return $ if passValid then Just email' else Nothing @@ -648,7 +653,7 @@ postLoginR = do let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier case maid of Just email' -> - lift $ setCredsRedirect $ Creds + setCredsRedirect $ Creds (if isEmail then "email" else "username") email' [("verifiedEmail", email')] @@ -658,26 +663,26 @@ postLoginR = do then Msg.InvalidEmailPass else Msg.InvalidUsernamePass -getPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent +getPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent getPasswordR = do - maid <- lift maybeAuthId + maid <- maybeAuthId case maid of Nothing -> loginErrorMessageI LoginR Msg.BadSetPass Just _ -> do - needOld <- maybe (return True) (lift . needOldPassword) maid + needOld <- maybe (return True) needOldPassword maid setPasswordHandler needOld -- | Default implementation of 'setPasswordHandler'. -- -- @since 1.2.6 -defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> HandlerT Auth (HandlerT master IO) TypedContent +defaultSetPasswordHandler :: YesodAuthEmail master => Bool -> AuthHandler master TypedContent defaultSetPasswordHandler needOld = do - messageRender <- lift getMessageRender + messageRender <- getMessageRender toParent <- getRouteToParent selectRep $ do provideJsonMessage $ messageRender Msg.SetPass - provideRep $ lift $ authLayout $ do - (widget, enctype) <- liftWidgetT $ generateFormPost setPasswordForm + provideRep $ authLayout $ do + (widget, enctype) <- generateFormPost setPasswordForm setTitleI Msg.SetPassTitle [whamlet|

_{Msg.SetPass} @@ -749,10 +754,10 @@ parsePassword = withObject "password" (\obj -> do curr <- obj .:? "current" return (email', pass, curr)) -postPasswordR :: YesodAuthEmail master => HandlerT Auth (HandlerT master IO) TypedContent +postPasswordR :: YesodAuthEmail master => AuthHandler master TypedContent postPasswordR = do - maid <- lift maybeAuthId - (creds :: Result Value) <- lift parseCheckJsonBody + maid <- maybeAuthId + (creds :: Result Value) <- parseCheckJsonBody let jcreds = case creds of Error _ -> Nothing Success val -> parseMaybe parsePassword val @@ -761,26 +766,26 @@ postPasswordR = do Nothing -> loginErrorMessageI LoginR Msg.BadSetPass Just aid -> do tm <- getRouteToParent - needOld <- lift $ needOldPassword aid + needOld <- needOldPassword aid if not needOld then confirmPassword aid tm jcreds else do - res <- lift $ runInputPostResult $ ireq textField "current" + res <- runInputPostResult $ ireq textField "current" let fcurrent = case res of FormSuccess currentPass -> Just currentPass _ -> Nothing let current = if doJsonParsing then getThird jcreds else fcurrent - mrealpass <- lift $ getPassword aid + mrealpass <- getPassword aid case (mrealpass, current) of (Nothing, _) -> - lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account" + loginErrorMessage (tm setpassR) "You do not currently have a password set on your account" (_, Nothing) -> loginErrorMessageI LoginR Msg.BadSetPass (Just realpass, Just current') -> do - passValid <- lift $ verifyPassword current' realpass + passValid <- verifyPassword current' realpass if passValid then confirmPassword aid tm jcreds - else lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again" + else loginErrorMessage (tm setpassR) "Invalid current password, please try again" where msgOk = Msg.PassUpdated @@ -789,7 +794,7 @@ postPasswordR = do getNewConfirm (Just (a,b,_)) = Just (a,b) getNewConfirm _ = Nothing confirmPassword aid tm jcreds = do - res <- lift $ runInputPostResult $ (,) + res <- runInputPostResult $ (,) <$> ireq textField "new" <*> ireq textField "confirm" let creds = if (isJust jcreds) @@ -803,21 +808,21 @@ postPasswordR = do if new /= confirm then loginErrorMessageI setpassR Msg.PassMismatch else do - isSecure <- lift $ checkPasswordSecurity aid new + isSecure <- checkPasswordSecurity aid new case isSecure of - Left e -> lift $ loginErrorMessage (tm setpassR) e + Left e -> loginErrorMessage (tm setpassR) e Right () -> do - salted <- lift $ hashAndSaltPassword new - y <- lift $ do + salted <- hashAndSaltPassword new + y <- do setPassword aid salted deleteSession loginLinkKey addMessageI "success" msgOk getYesod - mr <- lift getMessageRender + mr <- getMessageRender selectRep $ do provideRep $ - fmap asHtml $ lift $ redirect $ afterPasswordRoute y + fmap asHtml $ redirect $ afterPasswordRoute y provideJsonMessage (mr msgOk) saltLength :: Int 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/GoogleEmail2.hs b/yesod-auth/Yesod/Auth/GoogleEmail2.hs index 577e86a7..789006e2 100644 --- a/yesod-auth/Yesod/Auth/GoogleEmail2.hs +++ b/yesod-auth/Yesod/Auth/GoogleEmail2.hs @@ -2,6 +2,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} -- | Use an email address as an identifier via Google's login system. -- -- Note that this is a replacement for "Yesod.Auth.GoogleEmail", which depends @@ -54,16 +56,16 @@ import Yesod.Auth (Auth, AuthPlugin (AuthPlugin), AuthRoute, Creds (Creds), Route (PluginR), YesodAuth, runHttpRequest, setCredsRedirect, - logoutDest) + logoutDest, AuthHandler) import qualified Yesod.Auth.Message as Msg -import Yesod.Core (HandlerSite, HandlerT, MonadHandler, +import Yesod.Core (HandlerSite, MonadHandler, TypedContent, getRouteToParent, getUrlRender, invalidArgs, - lift, liftIO, lookupGetParam, + liftIO, lookupGetParam, lookupSession, notFound, redirect, setSession, whamlet, (.:), addMessage, getYesod, - toHtml) + toHtml, liftSubHandler) import Blaze.ByteString.Builder (fromByteString, toByteString) @@ -82,7 +84,7 @@ import qualified Data.Aeson.Encode as A import Data.Aeson.Parser (json') import Data.Aeson.Types (FromJSON (parseJSON), parseEither, parseMaybe, withObject, withText) -import Data.Conduit (($$+-), ($$)) +import Data.Conduit import Data.Conduit.Attoparsec (sinkParser) import qualified Data.HashMap.Strict as M import Data.Maybe (fromMaybe) @@ -187,10 +189,10 @@ authPlugin storeToken clientID clientSecret = dispatch :: YesodAuth site => Text -> [Text] - -> HandlerT Auth (HandlerT site IO) TypedContent + -> AuthHandler site TypedContent dispatch "GET" ["forward"] = do tm <- getRouteToParent - lift (getDest tm) >>= redirect + getDest tm >>= redirect dispatch "GET" ["complete"] = do mstate <- lookupGetParam "state" @@ -207,30 +209,27 @@ authPlugin storeToken clientID clientSecret = case merr of Nothing -> invalidArgs ["Missing code paramter"] Just err -> do - master <- lift getYesod + master <- getYesod let msg = case err of "access_denied" -> "Access denied" _ -> "Unknown error occurred: " `T.append` err addMessage "error" $ toHtml msg - lift $ redirect $ logoutDest master + redirect $ logoutDest master Just c -> return c render <- getUrlRender + tm <- getRouteToParent req' <- liftIO $ -#if MIN_VERSION_http_client(0,4,30) HTTP.parseUrlThrow -#else - HTTP.parseUrl -#endif "https://accounts.google.com/o/oauth2/token" -- FIXME don't hardcode, use: https://accounts.google.com/.well-known/openid-configuration let req = urlEncodedBody [ ("code", encodeUtf8 code) , ("client_id", encodeUtf8 clientID) , ("client_secret", encodeUtf8 clientSecret) - , ("redirect_uri", encodeUtf8 $ render complete) + , ("redirect_uri", encodeUtf8 $ render $ tm complete) , ("grant_type", "authorization_code") ] req' @@ -257,38 +256,31 @@ authPlugin storeToken clientID clientSecret = [e] -> return e [] -> error "No account email" x -> error $ "Too many account emails: " ++ show x - lift $ setCredsRedirect $ Creds pid email $ allPersonInfo personValue + setCredsRedirect $ Creds pid email $ allPersonInfo personValue dispatch _ _ = notFound -makeHttpRequest - :: (YesodAuth site) - => Request - -> HandlerT Auth (HandlerT site IO) A.Value -makeHttpRequest req = lift $ - runHttpRequest req $ \res -> bodyReaderSource (responseBody res) $$ sinkParser json' +makeHttpRequest :: Request -> AuthHandler site A.Value +makeHttpRequest req = + liftSubHandler $ runHttpRequest req $ \res -> + runConduit $ bodyReaderSource (responseBody res) .| sinkParser json' -- | Allows to fetch information about a user from Google's API. -- In case of parsing error returns 'Nothing'. -- Will throw 'HttpException' in case of network problems or error response code. -- -- @since 1.4.3 -getPerson :: Manager -> Token -> HandlerT site IO (Maybe Person) -getPerson manager token = parseMaybe parseJSON <$> (do +getPerson :: Manager -> Token -> AuthHandler site (Maybe Person) +getPerson manager token = liftSubHandler $ parseMaybe parseJSON <$> (do req <- personValueRequest token res <- http req manager - responseBody res $$+- sinkParser json' + runConduit $ responseBody res .| sinkParser json' ) personValueRequest :: MonadIO m => Token -> m Request personValueRequest token = do - req2' <- liftIO $ -#if MIN_VERSION_http_client(0,4,30) - HTTP.parseUrlThrow -#else - HTTP.parseUrl -#endif - "https://www.googleapis.com/plus/v1/people/me" + req2' <- liftIO + $ HTTP.parseUrlThrow "https://www.googleapis.com/plus/v1/people/me" return req2' { requestHeaders = [ ("Authorization", encodeUtf8 $ "Bearer " `mappend` accessToken token) diff --git a/yesod-auth/Yesod/Auth/Hardcoded.hs b/yesod-auth/Yesod/Auth/Hardcoded.hs index 9421feb4..cb5ec199 100644 --- a/yesod-auth/Yesod/Auth/Hardcoded.hs +++ b/yesod-auth/Yesod/Auth/Hardcoded.hs @@ -131,9 +131,10 @@ module Yesod.Auth.Hardcoded , loginR ) where -import Yesod.Auth (Auth, AuthPlugin (..), AuthRoute, +import Yesod.Auth (AuthPlugin (..), AuthRoute, Creds (..), Route (..), YesodAuth, - loginErrorMessageI, setCredsRedirect) + loginErrorMessageI, setCredsRedirect, + AuthHandler) import qualified Yesod.Auth.Message as Msg import Yesod.Core import Yesod.Form (ireq, runInputPost, textField) @@ -148,10 +149,10 @@ loginR = PluginR "hardcoded" ["login"] class (YesodAuth site) => YesodAuthHardcoded site where -- | Check whether given user name exists among hardcoded names. - doesUserNameExist :: Text -> HandlerT site IO Bool + doesUserNameExist :: Text -> AuthHandler site Bool -- | Validate given user name with given password. - validatePassword :: Text -> Text -> HandlerT site IO Bool + validatePassword :: Text -> Text -> AuthHandler site Bool authHardcoded :: YesodAuthHardcoded m => AuthPlugin m @@ -182,16 +183,16 @@ authHardcoded = |] -postLoginR :: (YesodAuthHardcoded master) - => HandlerT Auth (HandlerT master IO) TypedContent +postLoginR :: YesodAuthHardcoded site + => AuthHandler site TypedContent postLoginR = - do (username, password) <- lift (runInputPost + do (username, password) <- runInputPost ((,) Control.Applicative.<$> ireq textField "username" - Control.Applicative.<*> ireq textField "password")) - isValid <- lift (validatePassword username password) + Control.Applicative.<*> ireq textField "password") + isValid <- validatePassword username password if isValid - then lift (setCredsRedirect (Creds "hardcoded" username [])) - else do isExists <- lift (doesUserNameExist username) + then setCredsRedirect (Creds "hardcoded" username []) + else do isExists <- doesUserNameExist username loginErrorMessageI LoginR (if isExists then Msg.InvalidUsernamePass diff --git a/yesod-auth/Yesod/Auth/OpenId.hs b/yesod-auth/Yesod/Auth/OpenId.hs index f32ff747..ceaa312c 100644 --- a/yesod-auth/Yesod/Auth/OpenId.hs +++ b/yesod-auth/Yesod/Auth/OpenId.hs @@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} module Yesod.Auth.OpenId ( authOpenId , forwardUrl @@ -19,7 +20,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 (tryAny) import Data.Maybe (fromMaybe) import qualified Data.Text as T @@ -36,7 +37,10 @@ authOpenId idType extensionFields = AuthPlugin "openid" dispatch login where complete = PluginR "openid" ["complete"] + + name :: Text name = "openid_identifier" + login tm = do ident <- newIdent -- FIXME this is a hack to get GHC 7.6's type checker to allow the @@ -57,19 +61,19 @@ $newline never |] + + dispatch :: Text -> [Text] -> AuthHandler master TypedContent dispatch "GET" ["forward"] = do - roid <- lift $ runInputGet $ iopt textField name + roid <- runInputGet $ iopt textField name case roid of Just oid -> do + tm <- getRouteToParent render <- getUrlRender - let complete' = render complete - master <- lift getYesod - eres <- lift $ try $ OpenId.getForwardUrl oid complete' Nothing extensionFields (authHttpManager master) + let complete' = render $ tm complete + manager <- authHttpManager + eres <- tryAny $ OpenId.getForwardUrl oid complete' Nothing extensionFields manager case eres of - Left err -> do - tm <- getRouteToParent - lift $ loginErrorMessage (tm LoginR) $ T.pack $ - show (err :: SomeException) + Left err -> loginErrorMessage (tm LoginR) $ T.pack $ show err Right x -> redirect x Nothing -> loginErrorMessageI LoginR Msg.NoOpenID dispatch "GET" ["complete", ""] = dispatch "GET" ["complete"] -- compatibility issues @@ -84,14 +88,13 @@ $newline never completeHelper :: IdentifierType -> [(Text, Text)] -> AuthHandler master TypedContent completeHelper idType gets' = do - master <- lift getYesod - eres <- try $ OpenId.authenticateClaimed gets' (authHttpManager master) + manager <- authHttpManager + eres <- tryAny $ OpenId.authenticateClaimed gets' manager either onFailure onSuccess eres where onFailure err = do tm <- getRouteToParent - lift $ loginErrorMessage (tm LoginR) $ T.pack $ - show (err :: SomeException) + loginErrorMessage (tm LoginR) $ T.pack $ show err onSuccess oir = do let claimed = case OpenId.oirClaimed oir of @@ -105,7 +108,7 @@ completeHelper idType gets' = do case idType of OPLocal -> OpenId.oirOpLocal oir Claimed -> fromMaybe (OpenId.oirOpLocal oir) $ OpenId.oirClaimed oir - lift $ setCredsRedirect $ Creds "openid" i gets'' + setCredsRedirect $ Creds "openid" i gets'' -- | The main identifier provided by the OpenID authentication plugin is the -- \"OP-local identifier\". There is also sometimes a \"claimed\" identifier diff --git a/yesod-auth/Yesod/Auth/Rpxnow.hs b/yesod-auth/Yesod/Auth/Rpxnow.hs index 58456cda..b7a96a7c 100644 --- a/yesod-auth/Yesod/Auth/Rpxnow.hs +++ b/yesod-auth/Yesod/Auth/Rpxnow.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} module Yesod.Auth.Rpxnow ( authRpxnow ) where @@ -17,10 +18,10 @@ import Data.Text.Encoding.Error (lenientDecode) import Control.Arrow ((***)) import Network.HTTP.Types (renderQuery) -authRpxnow :: YesodAuth m +authRpxnow :: YesodAuth master => String -- ^ app name -> String -- ^ key - -> AuthPlugin m + -> AuthPlugin master authRpxnow app apiKey = AuthPlugin "rpxnow" dispatch login where @@ -32,14 +33,16 @@ authRpxnow app apiKey = $newline never