yesod-auth 1.3.4.6 → 1.4.0
raw patch · 4 files changed
+114/−152 lines, 4 filesdep ~persistentdep ~persistent-templatedep ~yesod-core
Dependency ranges changed: persistent, persistent-template, yesod-core, yesod-form, yesod-persistent
Files
- Yesod/Auth.hs +91/−144
- Yesod/Auth/Email.hs +16/−2
- Yesod/Auth/Routes.hs +1/−0
- yesod-auth.cabal +6/−6
Yesod/Auth.hs view
@@ -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
Yesod/Auth/Email.hs view
@@ -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)
Yesod/Auth/Routes.hs view
@@ -5,6 +5,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ViewPatterns #-} module Yesod.Auth.Routes where import Yesod.Core
yesod-auth.cabal view
@@ -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