From 086837686a4e051f91d5da6337b1f151820f382f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20G=C3=B3mez?= Date: Wed, 10 Sep 2014 17:51:11 +0000 Subject: [PATCH 1/4] Decouple YesodAuthPersist from Persistent --- yesod-auth/Yesod/Auth.hs | 136 ++++++++++++++++----------------------- 1 file changed, 57 insertions(+), 79 deletions(-) diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index 91d820e8..bcbb39ab 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/yesod-auth/Yesod/Auth.hs @@ -18,8 +18,7 @@ module Yesod.Auth , AuthPlugin (..) , getAuth , YesodAuth (..) - , YesodAuthPersist - , AuthEntity + , YesodAuthPersist (..) -- * Plugin interface , Creds (..) , setCreds @@ -162,14 +161,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage maybeAuthId :: HandlerT master IO (Maybe (AuthId master)) default maybeAuthId - :: ( YesodAuth master - , PersistEntityBackend val ~ YesodPersistBackend master - , Key val ~ AuthId master - , PersistStore (PersistEntityBackend val) - , PersistEntity val - , YesodPersist master - , Typeable val - ) + :: (YesodAuthPersist master, Typeable (AuthEntity master)) => HandlerT master IO (Maybe (AuthId master)) maybeAuthId = defaultMaybeAuthId @@ -193,40 +185,22 @@ credsKey = "_ID" -- -- Since 1.1.2 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)) -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 -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)) -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) @@ -368,51 +342,54 @@ handlePluginR plugin pieces = do ap:_ -> apDispatch ap method pieces -- | Similar to 'maybeAuthId', but additionally look up the value associated --- with the user\'s database identifier to get the value in the database. This --- assumes that you are using a Persistent database. +-- with the user\'s database identifier to get the value in the database. -- -- Since 1.1.0 -maybeAuth :: ( YesodAuth master - , b ~ YesodPersistBackend master - , b ~ PersistEntityBackend val - , Key val ~ AuthId master - , PersistStore b - , PersistEntity val - , YesodPersist master - , Typeable val - ) => HandlerT master IO (Maybe (Entity val)) +maybeAuth + :: (YesodAuthPersist master, Typeable (AuthEntity master)) + => HandlerT master IO (Maybe (AuthId master, AuthEntity master)) maybeAuth = 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. +-- | 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. -- --- Since 1.2.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) - ) +-- 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.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 :: * + + 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 + --- | 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 = KeyEntity (AuthId master) type family KeyEntity key type instance KeyEntity (Key x) = x @@ -427,7 +404,8 @@ requireAuthId = maybeAuthId >>= maybe handleAuthLack return -- 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 :: (YesodAuthPersist master, Typeable (AuthEntity master)) + => HandlerT master IO (AuthId master, AuthEntity master) requireAuth = maybeAuth >>= maybe handleAuthLack return handleAuthLack :: Yesod master => HandlerT master IO a From 4fd20299c12d8f64e3585ff370c13bc4a3b56c30 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20G=C3=B3mez?= Date: Fri, 12 Sep 2014 11:47:18 +0000 Subject: [PATCH 2/4] maybeAuthPair, requireAuthPair `maybeAuth` and `requireAuth` have been reverted to their original signatures, which assume a Persistent database. `maybeAuthPair` and `requireAuthPair` are introduced, which do the same but without that assumption. --- yesod-auth/Yesod/Auth.hs | 40 ++++++++++++++++++++++++++++++++++------ 1 file changed, 34 insertions(+), 6 deletions(-) diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index bcbb39ab..f2ea0ab0 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/yesod-auth/Yesod/Auth.hs @@ -28,8 +28,10 @@ module Yesod.Auth , loginErrorMessageI -- * User functions , defaultMaybeAuthId + , maybeAuthPair , maybeAuth , requireAuthId + , requireAuthPair , requireAuth -- * Exception , AuthException (..) @@ -342,13 +344,27 @@ handlePluginR plugin pieces = do ap:_ -> apDispatch ap method pieces -- | Similar to 'maybeAuthId', but additionally look up the value associated --- with the user\'s database identifier to get the value in the database. +-- with the user\'s database identifier to get the value in the database. This +-- assumes that you are using a Persistent database. -- -- Since 1.1.0 -maybeAuth - :: (YesodAuthPersist master, Typeable (AuthEntity master)) - => HandlerT master IO (Maybe (AuthId master, AuthEntity master)) +maybeAuth :: ( YesodAuthPersist master + , val ~ AuthEntity 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 + +-- | 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 ae <- MaybeT $ cachedAuth aid return (aid, ae) @@ -404,10 +420,22 @@ requireAuthId = maybeAuthId >>= maybe handleAuthLack return -- authenticated or responds with error 401 if this is an API client (expecting JSON). -- -- Since 1.1.0 -requireAuth :: (YesodAuthPersist master, Typeable (AuthEntity master)) - => HandlerT master IO (AuthId master, AuthEntity master) +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 From 9729cd9d153b51cfed7c05d66422e69f65ce204c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20G=C3=B3mez?= Date: Fri, 12 Sep 2014 13:18:51 +0000 Subject: [PATCH 3/4] Default type instance for AuthEntity `AuthEntity` is now a type family associated to the `YesodAuthPersist` class, so its old type alias definition has now become its default type instance, which allows recovering the old behavior with minimal boilerplate: an empty instance declaration for `YesodAuthPersist` makes a Yesod application written with Persistent work just like before. Unfortunately, this requires enabling `UndecidableInstances` in the `Yesod.Auth` module since there is now a nested type family application (as `AuthEntity` is now itself a type family). This was tested with the scaffolded application with PostgreSQL, and it works (given another small change to make it work with Persistent 2 due to how `SqlPersistT` is now defined). --- yesod-auth/Yesod/Auth.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index f2ea0ab0..78b2d734 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/yesod-auth/Yesod/Auth.hs @@ -9,6 +9,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Yesod.Auth ( -- * Subsite @@ -392,6 +393,7 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where -- -- Since 1.2.0 type AuthEntity master :: * + type instance AuthEntity master = KeyEntity (AuthId master) getAuthEntity :: AuthId master -> HandlerT master IO (Maybe (AuthEntity master)) From 94331fcab905f6010d35d07513b3fcfe7e65273c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Manuel=20G=C3=B3mez?= Date: Fri, 12 Sep 2014 13:35:00 +0000 Subject: [PATCH 4/4] Travis doesn't like `type instance` in a class --- yesod-auth/Yesod/Auth.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index 78b2d734..cbbadf37 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/yesod-auth/Yesod/Auth.hs @@ -393,7 +393,7 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where -- -- Since 1.2.0 type AuthEntity master :: * - type instance AuthEntity master = KeyEntity (AuthId master) + type AuthEntity master = KeyEntity (AuthId master) getAuthEntity :: AuthId master -> HandlerT master IO (Maybe (AuthEntity master))