Decouple YesodAuthPersist from Persistent

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