haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Relax a number of type signatures #1488

Browse Source
This commit is contained in:
Michael Snoyman 2018-02-20 13:51:19 +02:00
parent 63006970c6
commit a3f130233b
No known key found for this signature in database
GPG Key ID: A048E8C057E86876
3 changed files with 68 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
yesod-auth/ChangeLog.md
View File

@ -1,3 +1,7 @@
## 1.6.1
* Relax a number of type signatures [#1488](https://github.com/yesodweb/yesod/issues/1488)
## 1.6.0 ## 1.6.0
* Upgrade to yesod-core 1.6.0 * Upgrade to yesod-core 1.6.0

104
yesod-auth/Yesod/Auth.hs
View File

@ -112,7 +112,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
type AuthId master type AuthId master
-- | specify the layout. Uses defaultLayout by default -- | specify the layout. Uses defaultLayout by default
authLayout :: WidgetFor master () -> AuthHandler master Html authLayout :: (MonadHandler m, HandlerSite m ~ master) => WidgetFor master () -> m Html
authLayout = liftHandler . defaultLayout authLayout = liftHandler . defaultLayout
-- | Default destination on successful login, if no other -- | Default destination on successful login, if no other
@ -128,7 +128,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- Default implementation is in terms of @'getAuthId'@ -- Default implementation is in terms of @'getAuthId'@
-- --
-- @since: 1.4.4 -- @since: 1.4.4
authenticate :: Creds master -> AuthHandler master (AuthenticationResult master) authenticate :: (MonadHandler m, HandlerSite m ~ master) => Creds master -> m (AuthenticationResult master)
authenticate creds = do authenticate creds = do
muid <- getAuthId creds muid <- getAuthId creds
@ -138,7 +138,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- --
-- Default implementation is in terms of @'authenticate'@ -- Default implementation is in terms of @'authenticate'@
-- --
getAuthId :: Creds master -> AuthHandler master (Maybe (AuthId master)) getAuthId :: (MonadHandler m, HandlerSite m ~ master) => Creds master -> m (Maybe (AuthId master))
getAuthId creds = do getAuthId creds = do
auth <- authenticate creds auth <- authenticate creds
@ -185,7 +185,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- | When being redirected to the login page should the current page -- | When being redirected to the login page should the current page
-- be set to redirect back to. Default is 'True'. -- be set to redirect back to. Default is 'True'.
-- --
-- @since 1.4.21 -- @since 1.4.21
redirectToCurrent :: master -> Bool redirectToCurrent :: master -> Bool
redirectToCurrent _ = True redirectToCurrent _ = True
@ -194,16 +194,16 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- type. This allows backends to reuse persistent connections. If none of -- type. This allows backends to reuse persistent connections. If none of
-- the backends you're using use HTTP connections, you can safely return -- the backends you're using use HTTP connections, you can safely return
-- @error \"authHttpManager\"@ here. -- @error \"authHttpManager\"@ here.
authHttpManager :: AuthHandler master Manager authHttpManager :: (MonadHandler m, HandlerSite m ~ master) => m Manager
authHttpManager = liftIO getGlobalManager authHttpManager = liftIO getGlobalManager
-- | Called on a successful login. By default, calls -- | Called on a successful login. By default, calls
-- @addMessageI "success" NowLoggedIn@. -- @addMessageI "success" NowLoggedIn@.
onLogin :: AuthHandler master () onLogin :: (MonadHandler m, master ~ HandlerSite m) => m ()
onLogin = addMessageI "success" Msg.NowLoggedIn onLogin = addMessageI "success" Msg.NowLoggedIn
-- | Called on logout. By default, does nothing -- | Called on logout. By default, does nothing
onLogout :: AuthHandler master () onLogout :: (MonadHandler m, master ~ HandlerSite m) => m ()
onLogout = return () onLogout = return ()
-- | Retrieves user credentials, if user is authenticated. -- | Retrieves user credentials, if user is authenticated.
@ -215,16 +215,16 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage
-- other than a browser. -- other than a browser.
-- --
-- @since 1.2.0 -- @since 1.2.0
maybeAuthId :: AuthHandler master (Maybe (AuthId master)) maybeAuthId :: (MonadHandler m, master ~ HandlerSite m) => m (Maybe (AuthId master))
default maybeAuthId default maybeAuthId
:: (YesodAuthPersist master, Typeable (AuthEntity master)) :: (MonadHandler m, master ~ HandlerSite m, YesodAuthPersist master, Typeable (AuthEntity master))
=> AuthHandler master (Maybe (AuthId master)) => m (Maybe (AuthId master))
maybeAuthId = defaultMaybeAuthId maybeAuthId = defaultMaybeAuthId
-- | Called on login error for HTTP requests. By default, calls -- | Called on login error for HTTP requests. By default, calls
-- @addMessage@ with "error" as status and redirects to @dest@. -- @addMessage@ with "error" as status and redirects to @dest@.
onErrorHtml :: Route master -> Text -> AuthHandler master Html onErrorHtml :: (MonadHandler m, HandlerSite m ~ master) => Route master -> Text -> m Html
onErrorHtml dest msg = do onErrorHtml dest msg = do
addMessage "error" $ toHtml msg addMessage "error" $ toHtml msg
fmap asHtml $ redirect dest fmap asHtml $ redirect dest
@ -235,7 +235,7 @@ 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. -- 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 -- This is an experimental API that is not broadly used throughout the yesod-auth code base
runHttpRequest runHttpRequest
:: MonadAuthHandler master m :: (MonadHandler m, HandlerSite m ~ master, MonadUnliftIO m)
=> Request => Request
-> (Response BodyReader -> m a) -> (Response BodyReader -> m a)
-> m a -> m a
@ -261,8 +261,8 @@ credsKey = "_ID"
-- --
-- @since 1.1.2 -- @since 1.1.2
defaultMaybeAuthId defaultMaybeAuthId
:: (YesodAuthPersist master, Typeable (AuthEntity master)) :: (MonadHandler m, HandlerSite m ~ master, YesodAuthPersist master, Typeable (AuthEntity master))
=> AuthHandler master (Maybe (AuthId master)) => m (Maybe (AuthId master))
defaultMaybeAuthId = runMaybeT $ do defaultMaybeAuthId = runMaybeT $ do
s <- MaybeT $ lookupSession credsKey s <- MaybeT $ lookupSession credsKey
aid <- MaybeT $ return $ fromPathPiece s aid <- MaybeT $ return $ fromPathPiece s
@ -270,9 +270,13 @@ defaultMaybeAuthId = runMaybeT $ do
return aid return aid
cachedAuth cachedAuth
:: (YesodAuthPersist master, Typeable (AuthEntity master)) :: ( MonadHandler m
, YesodAuthPersist master
, Typeable (AuthEntity master)
, HandlerSite m ~ master
)
=> AuthId master => AuthId master
-> AuthHandler master (Maybe (AuthEntity master)) -> m (Maybe (AuthEntity master))
cachedAuth cachedAuth
= fmap unCachedMaybeAuth = fmap unCachedMaybeAuth
. cached . cached
@ -305,9 +309,10 @@ loginErrorMessageI dest msg = do
loginErrorMessageMasterI loginErrorMessageMasterI
:: Route master :: (MonadHandler m, HandlerSite m ~ master, YesodAuth master)
=> Route master
-> AuthMessage -> AuthMessage
-> AuthHandler master TypedContent -> m TypedContent
loginErrorMessageMasterI dest msg = do loginErrorMessageMasterI dest msg = do
mr <- getMessageRender mr <- getMessageRender
loginErrorMessage dest (mr msg) loginErrorMessage dest (mr msg)
@ -315,23 +320,24 @@ loginErrorMessageMasterI dest msg = do
-- | For HTML, set the message and redirect to the route. -- | For HTML, set the message and redirect to the route.
-- For JSON, send the message and a 401 status -- For JSON, send the message and a 401 status
loginErrorMessage loginErrorMessage
:: Route master :: (MonadHandler m, YesodAuth (HandlerSite m))
=> Route (HandlerSite m)
-> Text -> Text
-> AuthHandler master TypedContent -> m TypedContent
loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg) loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg)
messageJson401 messageJson401
:: MonadAuthHandler master m :: MonadHandler m
=> Text => Text
-> m Html -> m Html
-> m TypedContent -> m TypedContent
messageJson401 = messageJsonStatus unauthorized401 messageJson401 = messageJsonStatus unauthorized401
messageJson500 :: MonadAuthHandler master m => Text -> m Html -> m TypedContent messageJson500 :: MonadHandler m => Text -> m Html -> m TypedContent
messageJson500 = messageJsonStatus internalServerError500 messageJson500 = messageJsonStatus internalServerError500
messageJsonStatus messageJsonStatus
:: MonadAuthHandler master m :: MonadHandler m
=> Status => Status
-> Text -> Text
-> m Html -> m Html
@ -348,8 +354,9 @@ provideJsonMessage msg = provideRep $ return $ object ["message" .= msg]
setCredsRedirect setCredsRedirect
:: Creds master -- ^ new credentials :: (MonadHandler m, YesodAuth (HandlerSite m))
-> AuthHandler master TypedContent => Creds (HandlerSite m) -- ^ new credentials
-> m TypedContent
setCredsRedirect creds = do setCredsRedirect creds = do
y <- getYesod y <- getYesod
auth <- authenticate creds auth <- authenticate creds
@ -388,9 +395,10 @@ setCredsRedirect creds = do
return $ renderAuthMessage master langs msg return $ renderAuthMessage master langs msg
-- | Sets user credentials for the session after checking them with authentication backends. -- | Sets user credentials for the session after checking them with authentication backends.
setCreds :: Bool -- ^ if HTTP redirects should be done setCreds :: (MonadHandler m, YesodAuth (HandlerSite m))
-> Creds master -- ^ new credentials => Bool -- ^ if HTTP redirects should be done
-> AuthHandler master () -> Creds (HandlerSite m) -- ^ new credentials
-> m ()
setCreds doRedirects creds = setCreds doRedirects creds =
if doRedirects if doRedirects
then void $ setCredsRedirect creds then void $ setCredsRedirect creds
@ -412,8 +420,9 @@ authLayoutJson w json = selectRep $ do
-- | Clears current user credentials for the session. -- | Clears current user credentials for the session.
-- --
-- @since 1.1.7 -- @since 1.1.7
clearCreds :: Bool -- ^ if HTTP redirect to 'logoutDest' should be done clearCreds :: (MonadHandler m, YesodAuth (HandlerSite m))
-> AuthHandler master () => Bool -- ^ if HTTP redirect to 'logoutDest' should be done
-> m ()
clearCreds doRedirects = do clearCreds doRedirects = do
y <- getYesod y <- getYesod
onLogout onLogout
@ -442,7 +451,7 @@ $nothing
[ (T.pack "logged_in", Bool $ maybe False (const True) creds) [ (T.pack "logged_in", Bool $ maybe False (const True) creds)
] ]
setUltDestReferer' :: AuthHandler master () setUltDestReferer' :: (MonadHandler m, YesodAuth (HandlerSite m)) => m ()
setUltDestReferer' = do setUltDestReferer' = do
master <- getYesod master <- getYesod
when (redirectToReferer master) setUltDestReferer when (redirectToReferer master) setUltDestReferer
@ -477,7 +486,9 @@ maybeAuth :: ( YesodAuthPersist master
, Key val ~ AuthId master , Key val ~ AuthId master
, PersistEntity val , PersistEntity val
, Typeable val , Typeable val
) => AuthHandler master (Maybe (Entity val)) , MonadHandler m
, HandlerSite m ~ master
) => m (Maybe (Entity val))
maybeAuth = fmap (fmap (uncurry Entity)) maybeAuthPair maybeAuth = fmap (fmap (uncurry Entity)) maybeAuthPair
-- | Similar to 'maybeAuth', but doesn’t assume that you are using a -- | Similar to 'maybeAuth', but doesn’t assume that you are using a
@ -485,8 +496,12 @@ maybeAuth = fmap (fmap (uncurry Entity)) maybeAuthPair
-- --
-- @since 1.4.0 -- @since 1.4.0
maybeAuthPair maybeAuthPair
:: (YesodAuthPersist master, Typeable (AuthEntity master)) :: ( YesodAuthPersist master
=> AuthHandler master (Maybe (AuthId master, AuthEntity master)) , Typeable (AuthEntity master)
, MonadHandler m
, HandlerSite m ~ master
)
=> m (Maybe (AuthId master, AuthEntity master))
maybeAuthPair = runMaybeT $ do maybeAuthPair = runMaybeT $ do
aid <- MaybeT maybeAuthId aid <- MaybeT maybeAuthId
ae <- MaybeT $ cachedAuth aid ae <- MaybeT $ cachedAuth aid
@ -517,15 +532,18 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where
type AuthEntity master :: * type AuthEntity master :: *
type AuthEntity master = KeyEntity (AuthId master) type AuthEntity master = KeyEntity (AuthId master)
getAuthEntity :: AuthId master -> AuthHandler master (Maybe (AuthEntity master)) getAuthEntity :: (MonadHandler m, HandlerSite m ~ master)
=> AuthId master -> m (Maybe (AuthEntity master))
default getAuthEntity default getAuthEntity
:: ( YesodPersistBackend master ~ backend :: ( YesodPersistBackend master ~ backend
, PersistRecordBackend (AuthEntity master) backend , PersistRecordBackend (AuthEntity master) backend
, Key (AuthEntity master) ~ AuthId master , Key (AuthEntity master) ~ AuthId master
, PersistStore backend , PersistStore backend
, MonadHandler m
, HandlerSite m ~ master
) )
=> AuthId master -> AuthHandler master (Maybe (AuthEntity master)) => AuthId master -> m (Maybe (AuthEntity master))
getAuthEntity = liftHandler . runDB . get getAuthEntity = liftHandler . runDB . get
@ -536,7 +554,7 @@ type instance KeyEntity (Key x) = x
-- authenticated or responds with error 401 if this is an API client (expecting JSON). -- authenticated or responds with error 401 if this is an API client (expecting JSON).
-- --
-- @since 1.1.0 -- @since 1.1.0
requireAuthId :: AuthHandler master (AuthId master) requireAuthId :: (MonadHandler m, YesodAuth (HandlerSite m)) => m (AuthId (HandlerSite m))
requireAuthId = maybeAuthId >>= maybe handleAuthLack return requireAuthId = maybeAuthId >>= maybe handleAuthLack return
-- | Similar to 'maybeAuth', but redirects to a login page if user is not -- | Similar to 'maybeAuth', but redirects to a login page if user is not
@ -548,7 +566,9 @@ requireAuth :: ( YesodAuthPersist master
, Key val ~ AuthId master , Key val ~ AuthId master
, PersistEntity val , PersistEntity val
, Typeable val , Typeable val
) => AuthHandler master (Entity val) , MonadHandler m
, HandlerSite m ~ master
) => m (Entity val)
requireAuth = maybeAuth >>= maybe handleAuthLack return requireAuth = maybeAuth >>= maybe handleAuthLack return
-- | Similar to 'requireAuth', but not tied to Persistent's 'Entity' type. -- | Similar to 'requireAuth', but not tied to Persistent's 'Entity' type.
@ -558,16 +578,18 @@ requireAuth = maybeAuth >>= maybe handleAuthLack return
requireAuthPair requireAuthPair
:: ( YesodAuthPersist master :: ( YesodAuthPersist master
, Typeable (AuthEntity master) , Typeable (AuthEntity master)
, MonadHandler m
, HandlerSite m ~ master
) )
=> AuthHandler master (AuthId master, AuthEntity master) => m (AuthId master, AuthEntity master)
requireAuthPair = maybeAuthPair >>= maybe handleAuthLack return requireAuthPair = maybeAuthPair >>= maybe handleAuthLack return
handleAuthLack :: AuthHandler master a handleAuthLack :: (YesodAuth (HandlerSite m), MonadHandler m) => m a
handleAuthLack = do handleAuthLack = do
aj <- acceptsJson aj <- acceptsJson
if aj then notAuthenticated else redirectLogin if aj then notAuthenticated else redirectLogin
redirectLogin :: AuthHandler master a redirectLogin :: (YesodAuth (HandlerSite m), MonadHandler m) => m a
redirectLogin = do redirectLogin = do
y <- getYesod y <- getYesod
when (redirectToCurrent y) setUltDestCurrent when (redirectToCurrent y) setUltDestCurrent

2
yesod-auth/yesod-auth.cabal
View File

@ -1,5 +1,5 @@
name: yesod-auth name: yesod-auth
version: 1.6.0 version: 1.6.1
license: MIT license: MIT
license-file: LICENSE license-file: LICENSE
author: Michael Snoyman, Patrick Brisbin author: Michael Snoyman, Patrick Brisbin