yesod-auth-oauth2 0.5.1.0 → 0.5.2.0

raw patch · 7 files changed

+153/−81 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• src/Yesod/Auth/OAuth2/Dispatch.hs +48/−28
• src/Yesod/Auth/OAuth2/ErrorResponse.hs +21/−0
• src/Yesod/Auth/OAuth2/Exception.hs +29/−0
• src/Yesod/Auth/OAuth2/Nylas.hs +19/−15
• src/Yesod/Auth/OAuth2/Prelude.hs +23/−26
• src/Yesod/Auth/OAuth2/Slack.hs +10/−10
• yesod-auth-oauth2.cabal +3/−2

@@ -1,7 +1,9 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} module Yesod.Auth.OAuth2.Dispatch@@ -9,7 +11,7 @@     , dispatchAuthRequest     ) where -import Control.Exception.Safe (throwString, tryIO)+import Control.Exception.Safe import Control.Monad (unless, (<=<)) import Data.Monoid ((<>)) import Data.Text (Text)@@ -19,9 +21,10 @@ import Network.OAuth.OAuth2 import System.Random (newStdGen, randomRs) import URI.ByteString.Extension-import Yesod.Auth-import Yesod.Auth.OAuth2.ErrorResponse (onErrorResponse)-import Yesod.Core+import Yesod.Auth hiding (ServerError)+import Yesod.Auth.OAuth2.ErrorResponse+import Yesod.Auth.OAuth2.Exception+import Yesod.Core hiding (ErrorResponse)  -- | How to take an @'OAuth2Token'@ and retrieve user credentials type FetchCreds m = Manager -> OAuth2Token -> IO (Creds m)@@ -34,8 +37,10 @@     -> Text             -- ^ Method     -> [Text]           -- ^ Path pieces     -> AuthHandler m TypedContent-dispatchAuthRequest name oauth2 _ "GET" ["forward"] = dispatchForward name oauth2-dispatchAuthRequest name oauth2 getCreds "GET" ["callback"] = dispatchCallback name oauth2 getCreds+dispatchAuthRequest name oauth2 _ "GET" ["forward"] =+    dispatchForward name oauth2+dispatchAuthRequest name oauth2 getCreds "GET" ["callback"] =+    dispatchCallback name oauth2 getCreds dispatchAuthRequest _ _ _ _ _ = notFound  -- | Handle @GET \/forward@@@ -62,51 +67,63 @@     code <- requireGetParam "code"     manager <- authHttpManager     oauth2' <- withCallbackAndState name oauth2 csrf-    token <- denyLeft $ fetchAccessToken manager oauth2' $ ExchangeToken code-    creds <- denyLeft $ tryIO $ getCreds manager token+    token <- errLeft $ fetchAccessToken manager oauth2' $ ExchangeToken code+    creds <- errLeft $ tryFetchCreds $ getCreds manager token     setCredsRedirect creds   where-    -- On a Left result, log it and return an opaque permission-denied-    denyLeft :: (MonadHandler m, MonadLogger m, Show e) => IO (Either e a) -> m a-    denyLeft = either errInvalidOAuth pure <=< liftIO+    errLeft :: Show e => IO (Either e a) -> AuthHandler m a+    errLeft = either (errInvalidOAuth . unknownError . tshow) pure <=< liftIO -    errInvalidOAuth :: (MonadHandler m, MonadLogger m, Show e) => e -> m a+    errInvalidOAuth :: ErrorResponse -> AuthHandler m a     errInvalidOAuth err = do-        $(logError) $ T.pack $ "OAuth2 error: " <> show err-        permissionDenied "Invalid OAuth2 authentication attempt"+        $(logError) $ "OAuth2 error (" <> name <> "): " <> tshow err+        redirectMessage $ "Unable to log in with OAuth2: " <> erUserMessage err +redirectMessage :: Text -> AuthHandler m a+redirectMessage msg = do+    toParent <- getRouteToParent+    setMessage $ toHtml msg+    redirect $ toParent LoginR++tryFetchCreds :: IO a -> IO (Either SomeException a)+tryFetchCreds f =+    (Right <$> f)+        `catch` (\(ex :: IOException) -> pure $ Left $ toException ex)+        `catch` (\(ex :: YesodOAuth2Exception) -> pure $ Left $ toException ex)+ withCallbackAndState :: Text -> OAuth2 -> Text -> AuthHandler m OAuth2 withCallbackAndState name oauth2 csrf = do     let url = PluginR name ["callback"]     render <- getParentUrlRender     let callbackText = render url -    callback <- maybe-        (liftIO-            $ throwString-            $ "Invalid callback URI: "-            <> T.unpack callbackText-            <> ". Not using an absolute Approot?"-        ) pure $ fromText callbackText+    callback <-+        maybe+                (liftIO+                $ throwString+                $ "Invalid callback URI: "+                <> T.unpack callbackText+                <> ". Not using an absolute Approot?"+                )+                pure+            $ fromText callbackText      pure oauth2         { oauthCallback = Just callback-        , oauthOAuthorizeEndpoint = oauthOAuthorizeEndpoint oauth2-            `withQuery` [("state", encodeUtf8 csrf)]+        , oauthOAuthorizeEndpoint =+            oauthOAuthorizeEndpoint oauth2+                `withQuery` [("state", encodeUtf8 csrf)]         }  getParentUrlRender :: MonadHandler m => m (Route (SubHandlerSite m) -> Text)-getParentUrlRender = (.)-    <$> getUrlRender-    <*> getRouteToParent+getParentUrlRender = (.) <$> getUrlRender <*> getRouteToParent  -- | Set a random, 30-character value in the session setSessionCSRF :: MonadHandler m => Text -> m Text setSessionCSRF sessionKey = do     csrfToken <- liftIO randomToken     csrfToken <$ setSession sessionKey csrfToken-  where-    randomToken = T.pack . take 30 . randomRs ('a', 'z') <$> newStdGen+    where randomToken = T.pack . take 30 . randomRs ('a', 'z') <$> newStdGen  -- | Verify the callback provided the same CSRF token as in our session verifySessionCSRF :: MonadHandler m => Text -> m Text@@ -129,3 +146,6 @@  tokenSessionKey :: Text -> Text tokenSessionKey name = "_yesod_oauth2_" <> name++tshow :: Show a => a -> Text+tshow = T.pack . show

@@ -5,8 +5,10 @@ -- module Yesod.Auth.OAuth2.ErrorResponse     ( ErrorResponse(..)+    , erUserMessage     , ErrorName(..)     , onErrorResponse+    , unknownError     ) where  import Data.Foldable (traverse_)@@ -31,6 +33,25 @@     , erURI :: Maybe Text     }     deriving Show++-- | Textual value suitable for display to a User+erUserMessage :: ErrorResponse -> Text+erUserMessage err = case erName err of+    InvalidRequest -> "Invalid request"+    UnauthorizedClient -> "Unauthorized client"+    AccessDenied -> "Access denied"+    UnsupportedResponseType -> "Unsupported response type"+    InvalidScope -> "Invalid scope"+    ServerError -> "Server error"+    TemporarilyUnavailable -> "Temporarily unavailable"+    Unknown _ -> "Unknown error"++unknownError :: Text -> ErrorResponse+unknownError x = ErrorResponse+    { erName = Unknown x+    , erDescription = Nothing+    , erURI = Nothing+    }  -- | Check query parameters for an error, if found run the given action --

@@ -0,0 +1,29 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Yesod.Auth.OAuth2.Exception+    ( YesodOAuth2Exception(..)+    ) where++import Control.Exception.Safe+import Data.ByteString.Lazy (ByteString)+import Data.Text (Text)++data YesodOAuth2Exception+    = OAuth2Error Text ByteString+    -- ^ HTTP error during OAuth2 handshake+    --+    -- Plugin name and JSON-encoded @OAuth2Error@ from @hoauth2@.+    --+    | JSONDecodingError Text String+    -- ^ User profile was not as expected+    --+    -- Plugin name and Aeson parse error message.+    --+    | GenericError Text String+    -- ^ Other error conditions+    --+    -- Plugin name and error message.+    --+    deriving (Show, Typeable)++instance Exception YesodOAuth2Exception

@@ -10,6 +10,7 @@ import qualified Data.ByteString.Lazy.Char8 as BL8 import Network.HTTP.Client import qualified Network.HTTP.Types as HT+import qualified Yesod.Auth.OAuth2.Exception as YesodOAuth2Exception  newtype User = User Text @@ -34,31 +35,34 @@         -- FIXME: was this working? I'm 95% sure that the client will throw its         -- own exception on unsuccessful status codes.         unless (HT.statusIsSuccessful $ responseStatus resp)-            $ throwIO $ InvalidProfileResponse pluginName-            $ "Unsuccessful HTTP response: " <> userResponse-+            $ throwIO+            $ YesodOAuth2Exception.GenericError pluginName+            $ "Unsuccessful HTTP response: "+            <> BL8.unpack userResponse          either-            (throwIO . InvalidProfileResponse pluginName . BL8.pack)-            (\(User userId) -> pure Creds-                { credsPlugin = pluginName-                , credsIdent = userId-                , credsExtra = setExtra token userResponse-                }-            )+                (throwIO . YesodOAuth2Exception.JSONDecodingError pluginName)+                (\(User userId) -> pure Creds+                    { credsPlugin = pluginName+                    , credsIdent = userId+                    , credsExtra = setExtra token userResponse+                    }+                )             $ eitherDecode userResponse   where     oauth = OAuth2         { oauthClientId = clientId         , oauthClientSecret = clientSecret-        , oauthOAuthorizeEndpoint = "https://api.nylas.com/oauth/authorize" `withQuery`-            [ ("response_type", "code")-            , ("client_id", encodeUtf8 clientId)+        , oauthOAuthorizeEndpoint = "https://api.nylas.com/oauth/authorize"+            `withQuery` [ ("response_type", "code")+                        , ( "client_id"+                          , encodeUtf8 clientId+                          )             -- N.B. The scopes delimeter is unknown/untested. Verify that before             -- extracting this to an argument and offering a Scoped function. In             -- its current state, it doesn't matter because it's only one scope.-            , scopeParam "," defaultScopes-            ]+                        , scopeParam "," defaultScopes+                        ]         , oauthAccessTokenEndpoint = "https://api.nylas.com/oauth/token"         , oauthCallback = Nothing         }

@@ -1,5 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} -- |@@ -8,10 +6,9 @@ -- implementations. May also be useful for writing local providers. -- module Yesod.Auth.OAuth2.Prelude-    ( YesodOAuth2Exception(..)--    -- * Provider helpers-    , authGetProfile+    (+      -- * Provider helpers+      authGetProfile     , scopeParam     , setExtra @@ -63,7 +60,6 @@ import Data.Aeson import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Lazy.Char8 as BL8 import Data.Semigroup ((<>)) import Data.Text (Text) import qualified Data.Text as T@@ -74,16 +70,7 @@ import URI.ByteString.Extension import Yesod.Auth import Yesod.Auth.OAuth2---- | Provider name and error------ The error is a lazy bytestring because it's most often encoded JSON.------ Deprecated. Eventually, we'll return @Either@s all the way up.----data YesodOAuth2Exception = InvalidProfileResponse Text BL.ByteString-    deriving (Show, Typeable)-instance Exception YesodOAuth2Exception+import qualified Yesod.Auth.OAuth2.Exception as YesodOAuth2Exception  -- | Retrieve a user's profile as JSON --@@ -91,27 +78,37 @@ -- @'credsIdent'@. Additional information should either be re-parsed by or -- fetched via additional requests by consumers. ---authGetProfile :: FromJSON a => Text -> Manager -> OAuth2Token -> URI -> IO (a, BL.ByteString)+authGetProfile+    :: FromJSON a+    => Text+    -> Manager+    -> OAuth2Token+    -> URI+    -> IO (a, BL.ByteString) authGetProfile name manager token url = do     resp <- fromAuthGet name =<< authGetBS manager (accessToken token) url     decoded <- fromAuthJSON name resp     pure (decoded, resp) --- | Throws a @Left@ result as an @'InvalidProfileResponse'@-fromAuthGet :: Text -> Either (OAuth2Error Value) BL.ByteString -> IO BL.ByteString+-- | Throws a @Left@ result as an @'YesodOAuth2Exception'@+fromAuthGet+    :: Text -> Either (OAuth2Error Value) BL.ByteString -> IO BL.ByteString fromAuthGet _ (Right bs) = pure bs -- nice-fromAuthGet name (Left err) = throwIO $ InvalidProfileResponse name $ encode err+fromAuthGet name (Left err) =+    throwIO $ YesodOAuth2Exception.OAuth2Error name $ encode err --- | Throws a decoding error as an @'InvalidProfileResponse'@+-- | Throws a decoding error as an @'YesodOAuth2Exception'@ fromAuthJSON :: FromJSON a => Text -> BL.ByteString -> IO a fromAuthJSON name =-    -- FIXME: unique exception constructors-    either (throwIO . InvalidProfileResponse name . BL8.pack) pure . eitherDecode+    either (throwIO . YesodOAuth2Exception.JSONDecodingError name) pure+        . eitherDecode  -- | A tuple of @\"scope\"@ and the given scopes separated by a delimiter scopeParam :: Text -> [Text] -> (ByteString, ByteString)-scopeParam d = ("scope",) . encodeUtf8 . T.intercalate d+scopeParam d = ("scope", ) . encodeUtf8 . T.intercalate d +-- brittany-disable-next-binding+ -- | Construct part of @'credsExtra'@ -- -- Always the following keys:@@ -128,4 +125,4 @@     [ ("accessToken", atoken $ accessToken token)     , ("userResponse", decodeUtf8 $ BL.toStrict userResponse)     ]-    <> maybe [] (pure . ("refreshToken",) . rtoken) (refreshToken token)+    <> maybe [] (pure . ("refreshToken", ) . rtoken) (refreshToken token)

@@ -15,6 +15,7 @@  import Network.HTTP.Client     (httpLbs, parseUrlThrow, responseBody, setQueryString)+import Yesod.Auth.OAuth2.Exception as YesodOAuth2Exception  data SlackScope     = SlackBasicScope@@ -53,21 +54,20 @@         userResponse <- responseBody <$> httpLbs req manager          either-            (const $ throwIO $ InvalidProfileResponse pluginName userResponse)-            (\(User userId) -> pure Creds-                { credsPlugin = pluginName-                , credsIdent = userId-                , credsExtra = setExtra token userResponse-                }-            )+                (throwIO . YesodOAuth2Exception.JSONDecodingError pluginName)+                (\(User userId) -> pure Creds+                    { credsPlugin = pluginName+                    , credsIdent = userId+                    , credsExtra = setExtra token userResponse+                    }+                )             $ eitherDecode userResponse   where     oauth2 = OAuth2         { oauthClientId = clientId         , oauthClientSecret = clientSecret-        , oauthOAuthorizeEndpoint = "https://slack.com/oauth/authorize" `withQuery`-            [ scopeParam "," $ map scopeText scopes-            ]+        , oauthOAuthorizeEndpoint = "https://slack.com/oauth/authorize"+            `withQuery` [scopeParam "," $ map scopeText scopes]         , oauthAccessTokenEndpoint = "https://slack.com/api/oauth.access"         , oauthCallback = Nothing         }

@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: d660ecb1d27952349257ee5fad10d3bef5734b4e11646d20bec923fd77b1ae62+-- hash: 836f5ffe241a2e028ddd2e67244782536c9625183e274372c0c10708f2c13cc4  name:           yesod-auth-oauth2-version:        0.5.1.0+version:        0.5.2.0 synopsis:       OAuth 2.0 authentication plugins description:    Library to authenticate with OAuth 2.0 for Yesod web applications. category:       Web@@ -55,6 +55,7 @@       Yesod.Auth.OAuth2.Dispatch       Yesod.Auth.OAuth2.ErrorResponse       Yesod.Auth.OAuth2.EveOnline+      Yesod.Auth.OAuth2.Exception       Yesod.Auth.OAuth2.GitHub       Yesod.Auth.OAuth2.Github       Yesod.Auth.OAuth2.GitLab