diff --git a/Yesod/Auth.hs b/Yesod/Auth.hs --- a/Yesod/Auth.hs +++ b/Yesod/Auth.hs @@ -9,6 +9,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Yesod.Auth ( -- * Subsite @@ -18,8 +19,7 @@ , AuthPlugin (..) , getAuth , YesodAuth (..) - , YesodAuthPersist - , AuthEntity + , YesodAuthPersist (..) -- * Plugin interface , Creds (..) , setCreds @@ -29,8 +29,10 @@ , loginErrorMessageI -- * User functions , defaultMaybeAuthId + , maybeAuthPair , maybeAuth , requireAuthId + , requireAuthPair , requireAuth -- * Exception , AuthException (..) @@ -47,7 +49,7 @@ import Control.Monad.Trans.Maybe import Yesod.Auth.Routes -import Data.Aeson +import Data.Aeson hiding (json) import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode) import Data.Text (Text) @@ -161,30 +163,9 @@ -- Since 1.2.0 maybeAuthId :: HandlerT master IO (Maybe (AuthId master)) -#if MIN_VERSION_persistent(2, 0, 0) default maybeAuthId - :: ( YesodAuth master - , PersistEntityBackend val ~ YesodPersistBackend master - , Key val ~ AuthId master - , PersistStore (PersistEntityBackend val) - , PersistEntity val - , YesodPersist master - , Typeable val - ) - => HandlerT master IO (Maybe (AuthId master)) -#else - default maybeAuthId - :: ( YesodAuth master - , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val - , b ~ YesodPersistBackend master - , Key val ~ AuthId master - , PersistStore (b (HandlerT master IO)) - , PersistEntity val - , YesodPersist master - , Typeable val - ) + :: (YesodAuthPersist master, Typeable (AuthEntity master)) => HandlerT master IO (Maybe (AuthId master)) -#endif maybeAuthId = defaultMaybeAuthId -- | Called on login error for HTTP requests. By default, calls @@ -206,66 +187,23 @@ -- 'maybeAuthIdRaw' for more information. -- -- Since 1.1.2 -#if MIN_VERSION_persistent(2, 0, 0) defaultMaybeAuthId - :: ( YesodAuth master - , b ~ YesodPersistBackend master - , b ~ PersistEntityBackend val - , Key val ~ AuthId master - , PersistStore b - , PersistEntity val - , YesodPersist master - , Typeable val - ) => HandlerT master IO (Maybe (AuthId master)) -#else -defaultMaybeAuthId - :: ( YesodAuth master - , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val - , b ~ YesodPersistBackend master - , Key val ~ AuthId master - , PersistStore (b (HandlerT master IO)) - , PersistEntity val - , YesodPersist master - , Typeable val - ) => HandlerT master IO (Maybe (AuthId master)) -#endif -defaultMaybeAuthId = do - ms <- lookupSession credsKey - case ms of - Nothing -> return Nothing - Just s -> - case fromPathPiece s of - Nothing -> return Nothing - Just aid -> fmap (fmap entityKey) $ cachedAuth aid + :: (YesodAuthPersist master, Typeable (AuthEntity master)) + => HandlerT master IO (Maybe (AuthId master)) +defaultMaybeAuthId = runMaybeT $ do + s <- MaybeT $ lookupSession credsKey + aid <- MaybeT $ return $ fromPathPiece s + _ <- MaybeT $ cachedAuth aid + return aid -#if MIN_VERSION_persistent(2, 0, 0) -cachedAuth :: ( YesodAuth master - , b ~ YesodPersistBackend master - , b ~ PersistEntityBackend val - , Key val ~ AuthId master - , PersistStore b - , PersistEntity val - , YesodPersist master - , Typeable val - ) => AuthId master -> HandlerT master IO (Maybe (Entity val)) -#else -cachedAuth :: ( YesodAuth master - , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val - , b ~ YesodPersistBackend master - , Key val ~ AuthId master - , PersistStore (b (HandlerT master IO)) - , PersistEntity val - , YesodPersist master - , Typeable val - ) => AuthId master -> HandlerT master IO (Maybe (Entity val)) -#endif -cachedAuth aid = runMaybeT $ do - a <- MaybeT $ fmap unCachedMaybeAuth - $ cached - $ fmap CachedMaybeAuth - $ runDB - $ get aid - return $ Entity aid a +cachedAuth + :: (YesodAuthPersist master, Typeable (AuthEntity master)) + => AuthId master -> HandlerT master IO (Maybe (AuthEntity master)) +cachedAuth + = fmap unCachedMaybeAuth + . cached + . fmap CachedMaybeAuth + . getAuthEntity loginErrorMessageI :: (MonadResourceBase m, YesodAuth master) @@ -411,90 +349,99 @@ -- assumes that you are using a Persistent database. -- -- Since 1.1.0 -#if MIN_VERSION_persistent(2, 0, 0) -maybeAuth :: ( YesodAuth master - , b ~ YesodPersistBackend master - , b ~ PersistEntityBackend val +maybeAuth :: ( YesodAuthPersist master + , val ~ AuthEntity master , Key val ~ AuthId master - , PersistStore b , PersistEntity val - , YesodPersist master , Typeable val ) => HandlerT master IO (Maybe (Entity val)) -#else -maybeAuth :: ( YesodAuth master - , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend val - , b ~ YesodPersistBackend master - , Key val ~ AuthId master - , PersistStore (b (HandlerT master IO)) - , PersistEntity val - , YesodPersist master - , Typeable val - ) => HandlerT master IO (Maybe (Entity val)) -#endif maybeAuth = runMaybeT $ do + (aid, ae) <- MaybeT maybeAuthPair + return $ Entity aid ae + +-- | 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 = runMaybeT $ do aid <- MaybeT maybeAuthId - MaybeT $ cachedAuth aid + ae <- MaybeT $ cachedAuth aid + return (aid, ae) + newtype CachedMaybeAuth val = CachedMaybeAuth { unCachedMaybeAuth :: Maybe val } deriving Typeable --- | Constraint which states that the given site is an instance of @YesodAuth@ --- and that its @AuthId@ is in fact a persistent @Key@ for the given value. --- This is the common case in Yesod, and means that you can easily look up the --- full informatin on a given user. --- --- Since 1.2.0 -#if MIN_VERSION_persistent(2, 0, 0) -type YesodAuthPersist master = - ( YesodAuth master - , YesodPersistBackend master - ~ PersistEntityBackend (AuthEntity master) - , Key (AuthEntity master) ~ AuthId master - , PersistStore (YesodPersistBackend master) - , PersistEntity (AuthEntity master) - , YesodPersist master - , Typeable (AuthEntity master) - ) -#else -type YesodAuthPersist master = - ( YesodAuth master - , PersistMonadBackend (YesodPersistBackend master (HandlerT master IO)) - ~ PersistEntityBackend (AuthEntity master) - , Key (AuthEntity master) ~ AuthId master - , PersistStore (YesodPersistBackend master (HandlerT master IO)) - , PersistEntity (AuthEntity master) - , YesodPersist master - , Typeable (AuthEntity master) - ) -#endif - --- | If the @AuthId@ for a given site is a persistent ID, this will give the --- value for that entity. E.g.: +-- | Class which states that the given site is an instance of @YesodAuth@ +-- and that its @AuthId@ is a lookup key for the full user information in +-- a @YesodPersist@ database. -- --- > type AuthId MySite = UserId --- > AuthEntity MySite ~ User +-- The default implementation of @getAuthEntity@ assumes that the @AuthId@ +-- for the @YesodAuth@ superclass is in fact a persistent @Key@ for the +-- given value. This is the common case in Yesod, and means that you can +-- easily look up the full information on a given user. -- --- Since 1.2.0 -type AuthEntity master = KeyEntity (AuthId master) -#if MIN_VERSION_persistent(2, 0, 0) +-- Since 1.4.0 +class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where + -- | If the @AuthId@ for a given site is a persistent ID, this will give the + -- value for that entity. E.g.: + -- + -- > type AuthId MySite = UserId + -- > AuthEntity MySite ~ User + -- + -- Since 1.2.0 + type AuthEntity master :: * + type AuthEntity master = KeyEntity (AuthId master) + + getAuthEntity :: AuthId master -> HandlerT master IO (Maybe (AuthEntity master)) + + 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)) + getAuthEntity = runDB . get + + type family KeyEntity key type instance KeyEntity (Key x) = x -#endif -- | Similar to 'maybeAuthId', but redirects to a login page if user is not --- authenticated. +-- 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 = maybeAuthId >>= maybe redirectLogin return +requireAuthId = maybeAuthId >>= maybe handleAuthLack return -- | Similar to 'maybeAuth', but redirects to a login page if user is not --- authenticated. +-- authenticated or responds with error 401 if this is an API client (expecting JSON). -- -- Since 1.1.0 -requireAuth :: YesodAuthPersist master => HandlerT master IO (Entity (AuthEntity master)) -requireAuth = maybeAuth >>= maybe redirectLogin return +requireAuth :: ( YesodAuthPersist master + , val ~ AuthEntity master + , Key val ~ AuthId master + , PersistEntity val + , Typeable val + ) => HandlerT master IO (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 = maybeAuthPair >>= maybe handleAuthLack return + +handleAuthLack :: Yesod master => HandlerT master IO a +handleAuthLack = do + aj <- acceptsJson + if aj then notAuthenticated else redirectLogin redirectLogin :: Yesod master => HandlerT master IO a redirectLogin = do diff --git a/Yesod/Auth/Email.hs b/Yesod/Auth/Email.hs --- a/Yesod/Auth/Email.hs +++ b/Yesod/Auth/Email.hs @@ -3,6 +3,22 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE Rank2Types #-} +-- | A Yesod plugin for Authentication via e-mail +-- +-- This plugin works out of the box by only setting a few methods on the type class +-- that tell the plugin how to interoprate with your user data storage (your database). +-- However, almost everything is customizeable by setting more methods on the type class. +-- In addition, you can send all the form submissions via JSON and completely control the user's flow. +-- This is a standard registration e-mail flow +-- +-- 1) A user registers a new e-mail address, and an e-mail is sent there +-- 2) The user clicks on the registration link in the e-mail +-- Note that at this point they are actually logged in (without a password) +-- That means that when they log out they will need to reset their password +-- 3) The user sets their password and is redirected to the site. +-- 4) The user can now +-- * logout and sign in +-- * reset their password module Yesod.Auth.Email ( -- * Plugin authEmail @@ -36,9 +52,7 @@ import System.Random import qualified Data.Text as TS import qualified Data.Text as T -import qualified Data.Text.Lazy as TL import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy.Encoding as TLE import qualified Crypto.Hash.MD5 as H import Data.ByteString.Base16 as B16 import Data.Text.Encoding (encodeUtf8, decodeUtf8With) diff --git a/Yesod/Auth/Routes.hs b/Yesod/Auth/Routes.hs --- a/Yesod/Auth/Routes.hs +++ b/Yesod/Auth/Routes.hs @@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ViewPatterns #-} module Yesod.Auth.Routes where import Yesod.Core diff --git a/yesod-auth.cabal b/yesod-auth.cabal --- a/yesod-auth.cabal +++ b/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 1.3.4.6 +version: 1.4.0 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin @@ -28,7 +28,7 @@ build-depends: base >= 4 && < 5 , authenticate >= 1.3 , bytestring >= 0.9.1.4 - , yesod-core >= 1.2 && < 1.3 + , yesod-core >= 1.4 && < 1.5 , wai >= 1.4 , template-haskell , base16-bytestring @@ -36,17 +36,17 @@ , random >= 1.0.0.2 , text >= 0.7 , mime-mail >= 0.3 - , yesod-persistent >= 1.2 + , yesod-persistent >= 1.4 , hamlet >= 1.1 , shakespeare , shakespeare-css >= 1.0 , shakespeare-js >= 1.0.2 , containers , unordered-containers - , yesod-form >= 1.3 && < 1.4 + , yesod-form >= 1.4 && < 1.5 , transformers >= 0.2.2 - , persistent >= 1.2 && < 2.1 - , persistent-template >= 1.2 && < 2.1 + , persistent >= 2.1 && < 2.2 + , persistent-template >= 2.1 && < 2.2 , http-conduit >= 1.5 , aeson >= 0.7 , lifted-base >= 0.1