From a3f130233bbf4e6bfebdb7bfd3d926c689b53fd7 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Tue, 20 Feb 2018 13:51:19 +0200 Subject: [PATCH] Relax a number of type signatures #1488 --- yesod-auth/ChangeLog.md | 4 ++ yesod-auth/Yesod/Auth.hs | 104 ++++++++++++++++++++++-------------- yesod-auth/yesod-auth.cabal | 2 +- 3 files changed, 68 insertions(+), 42 deletions(-) diff --git a/yesod-auth/ChangeLog.md b/yesod-auth/ChangeLog.md index 69ac6519..216990ab 100644 --- a/yesod-auth/ChangeLog.md +++ b/yesod-auth/ChangeLog.md @@ -1,3 +1,7 @@ +## 1.6.1 + +* Relax a number of type signatures [#1488](https://github.com/yesodweb/yesod/issues/1488) + ## 1.6.0 * Upgrade to yesod-core 1.6.0 diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs index baae2e9e..e4cda58c 100644 --- a/yesod-auth/Yesod/Auth.hs +++ b/yesod-auth/Yesod/Auth.hs @@ -112,7 +112,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage type AuthId master -- | 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 -- | 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'@ -- -- @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 muid <- getAuthId creds @@ -138,7 +138,7 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage -- -- 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 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 -- be set to redirect back to. Default is 'True'. - -- + -- -- @since 1.4.21 redirectToCurrent :: master -> Bool 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 -- the backends you're using use HTTP connections, you can safely return -- @error \"authHttpManager\"@ here. - authHttpManager :: AuthHandler master Manager + authHttpManager :: (MonadHandler m, HandlerSite m ~ master) => m Manager authHttpManager = liftIO getGlobalManager -- | Called on a successful login. By default, calls -- @addMessageI "success" NowLoggedIn@. - onLogin :: AuthHandler master () + onLogin :: (MonadHandler m, master ~ HandlerSite m) => m () onLogin = addMessageI "success" Msg.NowLoggedIn -- | Called on logout. By default, does nothing - onLogout :: AuthHandler master () + onLogout :: (MonadHandler m, master ~ HandlerSite m) => m () onLogout = return () -- | Retrieves user credentials, if user is authenticated. @@ -215,16 +215,16 @@ class (Yesod master, PathPiece (AuthId master), RenderMessage master FormMessage -- other than a browser. -- -- @since 1.2.0 - maybeAuthId :: AuthHandler master (Maybe (AuthId master)) + maybeAuthId :: (MonadHandler m, master ~ HandlerSite m) => m (Maybe (AuthId master)) default maybeAuthId - :: (YesodAuthPersist master, Typeable (AuthEntity master)) - => AuthHandler master (Maybe (AuthId master)) + :: (MonadHandler m, master ~ HandlerSite m, YesodAuthPersist master, Typeable (AuthEntity master)) + => m (Maybe (AuthId master)) maybeAuthId = defaultMaybeAuthId -- | Called on login error for HTTP requests. By default, calls -- @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 addMessage "error" $ toHtml msg 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. -- This is an experimental API that is not broadly used throughout the yesod-auth code base runHttpRequest - :: MonadAuthHandler master m + :: (MonadHandler m, HandlerSite m ~ master, MonadUnliftIO m) => Request -> (Response BodyReader -> m a) -> m a @@ -261,8 +261,8 @@ credsKey = "_ID" -- -- @since 1.1.2 defaultMaybeAuthId - :: (YesodAuthPersist master, Typeable (AuthEntity master)) - => AuthHandler master (Maybe (AuthId master)) + :: (MonadHandler m, HandlerSite m ~ master, YesodAuthPersist master, Typeable (AuthEntity master)) + => m (Maybe (AuthId master)) defaultMaybeAuthId = runMaybeT $ do s <- MaybeT $ lookupSession credsKey aid <- MaybeT $ return $ fromPathPiece s @@ -270,9 +270,13 @@ defaultMaybeAuthId = runMaybeT $ do return aid cachedAuth - :: (YesodAuthPersist master, Typeable (AuthEntity master)) + :: ( MonadHandler m + , YesodAuthPersist master + , Typeable (AuthEntity master) + , HandlerSite m ~ master + ) => AuthId master - -> AuthHandler master (Maybe (AuthEntity master)) + -> m (Maybe (AuthEntity master)) cachedAuth = fmap unCachedMaybeAuth . cached @@ -305,9 +309,10 @@ loginErrorMessageI dest msg = do loginErrorMessageMasterI - :: Route master + :: (MonadHandler m, HandlerSite m ~ master, YesodAuth master) + => Route master -> AuthMessage - -> AuthHandler master TypedContent + -> m TypedContent loginErrorMessageMasterI dest msg = do mr <- getMessageRender loginErrorMessage dest (mr msg) @@ -315,23 +320,24 @@ loginErrorMessageMasterI dest msg = do -- | For HTML, set the message and redirect to the route. -- For JSON, send the message and a 401 status loginErrorMessage - :: Route master + :: (MonadHandler m, YesodAuth (HandlerSite m)) + => Route (HandlerSite m) -> Text - -> AuthHandler master TypedContent + -> m TypedContent loginErrorMessage dest msg = messageJson401 msg (onErrorHtml dest msg) messageJson401 - :: MonadAuthHandler master m + :: MonadHandler m => Text -> m Html -> m TypedContent messageJson401 = messageJsonStatus unauthorized401 -messageJson500 :: MonadAuthHandler master m => Text -> m Html -> m TypedContent +messageJson500 :: MonadHandler m => Text -> m Html -> m TypedContent messageJson500 = messageJsonStatus internalServerError500 messageJsonStatus - :: MonadAuthHandler master m + :: MonadHandler m => Status -> Text -> m Html @@ -348,8 +354,9 @@ provideJsonMessage msg = provideRep $ return $ object ["message" .= msg] setCredsRedirect - :: Creds master -- ^ new credentials - -> AuthHandler master TypedContent + :: (MonadHandler m, YesodAuth (HandlerSite m)) + => Creds (HandlerSite m) -- ^ new credentials + -> m TypedContent setCredsRedirect creds = do y <- getYesod auth <- authenticate creds @@ -388,9 +395,10 @@ setCredsRedirect creds = do return $ renderAuthMessage master langs msg -- | Sets user credentials for the session after checking them with authentication backends. -setCreds :: Bool -- ^ if HTTP redirects should be done - -> Creds master -- ^ new credentials - -> AuthHandler master () +setCreds :: (MonadHandler m, YesodAuth (HandlerSite m)) + => Bool -- ^ if HTTP redirects should be done + -> Creds (HandlerSite m) -- ^ new credentials + -> m () setCreds doRedirects creds = if doRedirects then void $ setCredsRedirect creds @@ -412,8 +420,9 @@ authLayoutJson w json = selectRep $ do -- | Clears current user credentials for the session. -- -- @since 1.1.7 -clearCreds :: Bool -- ^ if HTTP redirect to 'logoutDest' should be done - -> AuthHandler master () +clearCreds :: (MonadHandler m, YesodAuth (HandlerSite m)) + => Bool -- ^ if HTTP redirect to 'logoutDest' should be done + -> m () clearCreds doRedirects = do y <- getYesod onLogout @@ -442,7 +451,7 @@ $nothing [ (T.pack "logged_in", Bool $ maybe False (const True) creds) ] -setUltDestReferer' :: AuthHandler master () +setUltDestReferer' :: (MonadHandler m, YesodAuth (HandlerSite m)) => m () setUltDestReferer' = do master <- getYesod when (redirectToReferer master) setUltDestReferer @@ -477,7 +486,9 @@ maybeAuth :: ( YesodAuthPersist master , Key val ~ AuthId master , PersistEntity val , Typeable val - ) => AuthHandler master (Maybe (Entity val)) + , MonadHandler m + , HandlerSite m ~ master + ) => m (Maybe (Entity val)) maybeAuth = fmap (fmap (uncurry Entity)) maybeAuthPair -- | 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 maybeAuthPair - :: (YesodAuthPersist master, Typeable (AuthEntity master)) - => AuthHandler master (Maybe (AuthId master, AuthEntity master)) + :: ( YesodAuthPersist master + , Typeable (AuthEntity master) + , MonadHandler m + , HandlerSite m ~ master + ) + => m (Maybe (AuthId master, AuthEntity master)) maybeAuthPair = runMaybeT $ do aid <- MaybeT maybeAuthId ae <- MaybeT $ cachedAuth aid @@ -517,15 +532,18 @@ class (YesodAuth master, YesodPersist master) => YesodAuthPersist master where type AuthEntity 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 :: ( YesodPersistBackend master ~ backend , PersistRecordBackend (AuthEntity master) backend , Key (AuthEntity master) ~ AuthId master , PersistStore backend + , MonadHandler m + , HandlerSite m ~ master ) - => AuthId master -> AuthHandler master (Maybe (AuthEntity master)) + => AuthId master -> m (Maybe (AuthEntity master)) 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). -- -- @since 1.1.0 -requireAuthId :: AuthHandler master (AuthId master) +requireAuthId :: (MonadHandler m, YesodAuth (HandlerSite m)) => m (AuthId (HandlerSite m)) requireAuthId = maybeAuthId >>= maybe handleAuthLack return -- | Similar to 'maybeAuth', but redirects to a login page if user is not @@ -548,7 +566,9 @@ requireAuth :: ( YesodAuthPersist master , Key val ~ AuthId master , PersistEntity val , Typeable val - ) => AuthHandler master (Entity val) + , MonadHandler m + , HandlerSite m ~ master + ) => m (Entity val) requireAuth = maybeAuth >>= maybe handleAuthLack return -- | Similar to 'requireAuth', but not tied to Persistent's 'Entity' type. @@ -558,16 +578,18 @@ requireAuth = maybeAuth >>= maybe handleAuthLack return requireAuthPair :: ( YesodAuthPersist 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 -handleAuthLack :: AuthHandler master a +handleAuthLack :: (YesodAuth (HandlerSite m), MonadHandler m) => m a handleAuthLack = do aj <- acceptsJson if aj then notAuthenticated else redirectLogin -redirectLogin :: AuthHandler master a +redirectLogin :: (YesodAuth (HandlerSite m), MonadHandler m) => m a redirectLogin = do y <- getYesod when (redirectToCurrent y) setUltDestCurrent diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal index e6be61aa..4d31c440 100644 --- a/yesod-auth/yesod-auth.cabal +++ b/yesod-auth/yesod-auth.cabal @@ -1,5 +1,5 @@ name: yesod-auth -version: 1.6.0 +version: 1.6.1 license: MIT license-file: LICENSE author: Michael Snoyman, Patrick Brisbin