From 016ef10b0a429d7c2b0c7d83914316f2211cc36b Mon Sep 17 00:00:00 2001 From: Igor Pashev Date: Sun, 6 Aug 2017 19:22:28 +0300 Subject: Fix POST requests for tokens Really use application/x-www-form-urlencoded instead of query paramaters. Apparently, Google and LinkedIn are too tolerant. Yandex is not. --- src/Sproxy/Application/OAuth2/Google.hs | 122 +++++++++++++++++--------------- 1 file changed, 64 insertions(+), 58 deletions(-) (limited to 'src/Sproxy/Application/OAuth2/Google.hs') diff --git a/src/Sproxy/Application/OAuth2/Google.hs b/src/Sproxy/Application/OAuth2/Google.hs index 5a1834c..b2ea2c1 100644 --- a/src/Sproxy/Application/OAuth2/Google.hs +++ b/src/Sproxy/Application/OAuth2/Google.hs @@ -1,81 +1,87 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} -module Sproxy.Application.OAuth2.Google ( - provider -) where + +module Sproxy.Application.OAuth2.Google + ( provider + ) where import Control.Applicative (empty) import Control.Exception (Exception, throwIO) -import Data.Aeson (FromJSON, decode, parseJSON, Value(Object), (.:)) +import Data.Aeson + (FromJSON, Value(Object), (.:), decode, parseJSON) import Data.ByteString.Lazy (ByteString) import Data.Monoid ((<>)) import Data.Text (Text, unpack) import Data.Typeable (Typeable) -import Network.HTTP.Types (hContentType) -import Network.HTTP.Types.URI (urlEncode) import qualified Network.HTTP.Conduit as H +import Network.HTTP.Types.URI (urlEncode) -import Sproxy.Application.Cookie (newUser, setFamilyName, setGivenName) -import Sproxy.Application.OAuth2.Common (AccessTokenBody(accessToken), OAuth2Client(..), OAuth2Provider) - +import Sproxy.Application.Cookie + (newUser, setFamilyName, setGivenName) +import Sproxy.Application.OAuth2.Common + (AccessTokenBody(accessToken), OAuth2Client(..), OAuth2Provider) provider :: OAuth2Provider provider (client_id, client_secret) = - OAuth2Client { - oauth2Description = "Google" - , oauth2AuthorizeURL = \state redirect_uri -> - "https://accounts.google.com/o/oauth2/v2/auth" - <> "?scope=" <> urlEncode True "https://www.googleapis.com/auth/userinfo.email https://www.googleapis.com/auth/userinfo.profile" - <> "&client_id=" <> urlEncode True client_id - <> "&prompt=select_account" - <> "&redirect_uri=" <> urlEncode True redirect_uri - <> "&response_type=code" - <> "&state=" <> urlEncode True state - - , oauth2Authenticate = \code redirect_uri -> do - let treq = H.setQueryString [ - ("client_id" , Just client_id) - , ("client_secret" , Just client_secret) - , ("code" , Just code) - , ("grant_type" , Just "authorization_code") - , ("redirect_uri" , Just redirect_uri) - ] $ (H.parseRequest_ "POST https://www.googleapis.com/oauth2/v4/token") { - H.requestHeaders = [ - (hContentType, "application/x-www-form-urlencoded") - ] - } - mgr <- H.newManager H.tlsManagerSettings - tresp <- H.httpLbs treq mgr - case decode $ H.responseBody tresp of - Nothing -> throwIO $ GoogleException tresp - Just atResp -> do - ureq <- H.parseRequest $ unpack ("https://www.googleapis.com/oauth2/v1/userinfo?access_token=" <> accessToken atResp) - uresp <- H.httpLbs ureq mgr - case decode $ H.responseBody uresp of - Nothing -> throwIO $ GoogleException uresp - Just u -> return $ setFamilyName (familyName u) $ - setGivenName (givenName u) $ - newUser (email u) + OAuth2Client + { oauth2Description = "Google" + , oauth2AuthorizeURL = + \state redirect_uri -> + "https://accounts.google.com/o/oauth2/v2/auth" <> "?scope=" <> + urlEncode + True + "https://www.googleapis.com/auth/userinfo.email https://www.googleapis.com/auth/userinfo.profile" <> + "&client_id=" <> + urlEncode True client_id <> + "&prompt=select_account" <> + "&redirect_uri=" <> + urlEncode True redirect_uri <> + "&response_type=code" <> + "&state=" <> + urlEncode True state + , oauth2Authenticate = + \code redirect_uri -> do + let treq = + H.urlEncodedBody + [ ("client_id", client_id) + , ("client_secret", client_secret) + , ("code", code) + , ("grant_type", "authorization_code") + , ("redirect_uri", redirect_uri) + ] $ + H.parseRequest_ "POST https://www.googleapis.com/oauth2/v4/token" + mgr <- H.newManager H.tlsManagerSettings + tresp <- H.httpLbs treq mgr + case decode $ H.responseBody tresp of + Nothing -> throwIO $ GoogleException tresp + Just atResp -> do + ureq <- + H.parseRequest $ + unpack + ("https://www.googleapis.com/oauth2/v1/userinfo?access_token=" <> + accessToken atResp) + uresp <- H.httpLbs ureq mgr + case decode $ H.responseBody uresp of + Nothing -> throwIO $ GoogleException uresp + Just u -> + return $ + setFamilyName (familyName u) $ + setGivenName (givenName u) $ newUser (email u) } - -data GoogleException = GoogleException (H.Response ByteString) +data GoogleException = + GoogleException (H.Response ByteString) deriving (Show, Typeable) - instance Exception GoogleException - -data GoogleUserInfo = GoogleUserInfo { - email :: Text -, givenName :: Text -, familyName :: Text -} deriving (Eq, Show) +data GoogleUserInfo = GoogleUserInfo + { email :: Text + , givenName :: Text + , familyName :: Text + } deriving (Eq, Show) instance FromJSON GoogleUserInfo where - parseJSON (Object v) = GoogleUserInfo - <$> v .: "email" - <*> v .: "given_name" - <*> v .: "family_name" + parseJSON (Object v) = + GoogleUserInfo <$> v .: "email" <*> v .: "given_name" <*> v .: "family_name" parseJSON _ = empty - -- cgit v1.2.3